'I allow the user to get the view (yellow-button) menu and the application (blue-button) menu using the red (mouse) button in the title bar of a SpecialSystemView. If the mouse is in the title itself, the application menu is invoked. If the mouse is in the gray area to either side of the title, then the view menu is invoked.'!
"Give access to menus when the mouse (red button) goes down in the label part of my view. If the mouse is in the text box, act as though the yellow button were pressed (the application menu, by convention) otherwise, act as though the blue button were pressed (the view menu, by convention)."
request: 'Type the performance rate in percent followed by a CR'
initialAnswer: view rate printString) asNumber.
newRate > 0 ifTrue: [view rate: newRate].!
showVoiceCounts
| tallys out |
tallys _ Bag new.
model do:
[: scoreElement |
(scoreElement isNote)
ifTrue: [tallys add: scoreElement voice]].
out _ OrderedCollection new.
(tallys sortedElements) do:
[: assoc |
out addLast:
'Voice ', assoc key printString, ': ',
assoc value printString].
out inspect.! !
!PianoRollController methodsFor: 'scrolling'!
computeMarkerRegion
"Answer a rectangle for the marker region of the scroll bar. This rectangle should have an orgin of 0@0, a width of 10, and a height that is proportional to the percentage of the full score that is currently visible."
"Process user activity. This consists of either red button gestures or yellow button menu activity. Any other activity is handled by my superclass. Examples of gestures are: click, double-click, drag, and sweep (a special kind of drag). See the 'gestures' category for the full list."
"Perform action for a red button click at the given point. The default is to do vanilla red button activity."
self redButtonActivity.!
doubleClickAt: aPoint
"Perform action for a red button double-click at the given point. The default is to do vanilla red button activity."
self redButtonActivity.!
dragAt: aPoint
"Perform action for a red button drag starting at the given point. The default is to do vanilla red button activity."
self redButtonActivity.!
redButtonActivity
"If the subclass does not override a gesture messages, it is sent this message to perform vanilla red button activity. This default method does nothing."!
sweepAt: aPoint
"Perform action for a red button sweep starting at the given point. (A sweep is a diagonal down-and-right drag, used by some applications to sweep out an area for group selection.) The default is to do vanilla red button activity."
self redButtonActivity.! !
!GestureController methodsFor: 'menu handling'!
menuActivity
"If the yellow button is pressed, this message is sent to the controller to handle the application menu. It is up to subclasses to override this message. This default method does nothing."! !
!GestureController methodsFor: 'private-timer'!
resetTimer
"Reset our timer by remembering the current value of the millisecond clock."
startTime _ Time millisecondClockValue.!
timeOut: timeOutInMilliseconds
"Compute the timer value by subtracting the time at which the timer was last reset from the current millisecond clock value. Answer true if the result is greater than timeOutInMilliseconds."
| timerVal |
timerVal _ Time millisecondClockValue - startTime.
"The button was held down too long for it to be a click so it is either a drag or a sweep. It is considered a sweep if the mouse has moved in definite downward-and-right manner between the time the button was depressed and now. (Note that the constants in this method may need to be changed if the timeout in possibleClickAt: is changed.)"
| delta |
delta _ sensor cursorPoint - aPoint.
((delta x > 1) | (delta y > 1))
ifTrue: [self sweepAt: aPoint]
ifFalse: [self dragAt: aPoint].!
possibleClickAt: aPoint
"Invoked when the red button is first depressed. If the button is released before the timeout period has elapsed, then there is at least one click and we must look for a second click. Otherwise, the gesture is a drag or sweep."
self resetTimer.
[(self timeOut: 150) not & sensor redButtonPressed]
whileTrue: ["wait for timeout or button up"].
(sensor redButtonPressed not) "has the button gone up?"
ifTrue: [self possibleDoubleClickAt: aPoint]
ifFalse: [self dragOrSweepAt: aPoint].!
possibleDoubleClickAt: aPoint
"Invoked after the first click (i.e. the button is up). If the button is depressed again before the timeout period has elapsed, then the gesture is a double click. Otherwise, the gesture is a single click. A single click is recorded immediately. Thus, a double click causes the sequence of messages: 'clickAt:' and 'doubleClickAt:' to be sent."
self resetTimer.
[(self timeOut: 190) not & sensor redButtonPressed not]
whileTrue: ["wait for timeout or button down"].
(sensor redButtonPressed) "has the button gone down?"
ifTrue: [self doubleClickAt: aPoint]
ifFalse: [self clickAt: aPoint].! !
SceneController comment:
'I am a controller for SceneViews. I support gestures for scrolling, click-selection, and area selection of scene glyphs. I also support construction operations such as inserting new glyphs and merging glyphs to make them share a common point.'!
"Note: replace the previous code with the following to disable click, drag, and sweep gestures in 'operate' mode. This is good for naive users and quick response."
"If the mouse is clicked over a glyph that wants mouse input and we are in 'run' mode, pass the mouse to it. Otherwise, select the glyph under aPoint. If the shift key is depressed, the glyph's inclusion in the selection is toggled: that is, it is added to the selection if it is not currently selected and removed from the selection if it is currently selected."
"first, try to process mouse input for the glyph at aPoint"
"Handle a double-click action by trying to inspect the glyph under aPoint. A double-click that is not over any glyph does a selectAll."
| glyph |
glyph _ self glyphAt: aPoint.
(glyph notNil)
ifTrue:
[model clearSelection.
self selectAt: aPoint toggleFlag: false.
view displayScene.
self inspectGlyph]
ifFalse:
[self selectAll.
sensor waitNoButton].!
dragAt: aPoint
"Handle a drag action. If aPoint is over a glyph that is interested in mouse actions, let that glyph handle the mouse. Otherwise, move or scroll depending on whether or not the given point is over a selectable glyph or not."
| glyph |
"first, try to process mouse input for the glyph at aPoint"
(self processMouseAt: aPoint) ifTrue: [^self].
"if that fails, handle the normal move-or-scroll situation"
glyph _ self glyphAt: aPoint.
(glyph notNil)
ifTrue:
["if the glyph is not in the selection, select it"
"If we are in 'run' mode and the given point is over a glyph that is interested in mouse actions, let that glyph handle the mouse and answer true. Otherwise, answer false."
| mouseGlyph t |
running ifFalse: [^false].
mouseGlyph _ self mouseGlyphAt: aPoint.
(mouseGlyph notNil)
ifTrue: [self passMouseTo: mouseGlyph. ^true]
ifFalse: [^false].!
sweepAt: aPoint
"Handle a sweep gesture by doing an area-select. If the shift key is down, then toggle select all enclosed glyphs. Otherwise, clear the selection first. If there was a glyph under the mouse at the start of the sweep, consider it a drag (what a drag!!)."
"first, try to process mouse input for the glyph at aPoint"
(self processMouseAt: aPoint) ifTrue: [^self].
"if that fails, handle the normal move-or-area-select situation"
((self glyphAt: aPoint) notNil) "check for a drag situation"
ifTrue: [self dragAt: aPoint]
ifFalse:
[self
selectAreaAt: aPoint
toggleFlag: (sensor leftShiftDown)].! !
!SceneController methodsFor: 'menu handling'!
addMenuItems: debugging
"Answer my yellow-button menu given the current selection and possibly some other view or controller state. The goal is to present in the menu only those possibilities which are legal commands at this juncture. If debugging is true, present a additional options which might be useful to implementors and other gurus."
"Present the yellow button menu and determine which menu item, if any, the user selected. If an item was selected, then send that message to the object designated as the menu message receiver. Remember the menu item across menu invocations."
| menu item |
menu _ self yellowButtonMenu: (sensor leftShiftDown).
(menu isNil) ifTrue: [^self].
item _ menu invoke: lastMenuItem.
lastMenuItem _ item.
(item notNil) ifTrue: [self perform: item].!
yellowButtonMenu: debugging
"Answer my yellow-button menu, constructed by sending myself the message 'addMenuItems: debugging.' Items are appended to the CustomMenu myMenu; this allows subclasses to augment the menu provided by their superclass without the maintainance headache of copying the menu creation code into the subclass."
myMenu _ CustomMenu new.
self addMenuItems: debugging.
^myMenu! !
!SceneController methodsFor: 'menu operations'!
alignHorizontal
"Constrain all selected glyphs have the y location of the left-most selected glyph."
| args leftMost newY |
args _ model selected asOrderedCollection.
leftMost _ args first.
args do:
[: g |
(g locationPoints first x < leftMost locationPoints first x) ifTrue:
[leftMost _ g]].
args remove: leftMost.
newY _ leftMost locationPoints first y.
args do:
[: g |
LayoutConstraint
hAlign: (g locationPoints first)
with: (leftMost locationPoints first)].
leftMost locationPoints first y: newY.
view computeEnclosingRectangle.
view displayScene.!
alignVertical
"Constrain all selected glyphs have the x location of the top-most selected glyph."
| args topMost newX |
args _ model selected asOrderedCollection.
topMost _ args first.
args do:
[: g |
(g locationPoints first y < topMost locationPoints first y) ifTrue:
[topMost _ g]].
args remove: topMost.
newX _ topMost locationPoints first x.
args do:
[: g |
LayoutConstraint
vAlign: (g locationPoints first)
with: (topMost locationPoints first)].
topMost locationPoints first x: newX.
view computeEnclosingRectangle.
view displayScene.!
clearSelection
"Unselect everything."
model clearSelection.
view displayScene.!
delete
"Delete all the selected glyphs and their parents."
self deleteGlyphs: model selected.!
edit
running _ false.!
equate
"Add a user-defined equality constraint between subparts of the two selected glyphs."
| args first second firstPath secondPath |
args _ model selected asOrderedCollection.
(args first locationPoints first x < args last locationPoints first x)
ifTrue: [first _ args first. second _ args last]
ifFalse: [second _ args first. first _ args last].
firstPath _ FillInTheBlank
request:
'Path for the subpart of interest in the left-hand glyph (', first printString, ').
Use dot notation to specify the path (e.g. ''line1.p1.x'').'.
(firstPath size = 0) ifTrue: [^self].
secondPath _ FillInTheBlank
request:
'Path for the subpart of interest in the right-hand glyph (', second printString, ').
Use dot notation to specify the path (e.g. ''line1.p1.x'').'.
(secondPath size = 0) ifTrue: [^self].
UserEqualityConstraint
var: (Constraint getVarAt: firstPath in: first)
var: (Constraint getVarAt: secondPath in: second)
strength: #strongPreferred.
view computeEnclosingRectangle.
view displayScene.!
insert
"Prompt the user with a menu of glyph classes and add a new instance of the selected class."
| className |
className _ self partsMenu startUp.
(className = 0) ifTrue: [^self].
self addAndPlace: (Smalltalk at: className) new.!
inspectGlyph
"If a single glyph is selected, inspect it."
(self argument notNil) ifTrue:
[self argument inspect].!
merge
"Attempt the merge the selected glyphs together. The first glyph is the sink with which the remaining glyphs are merged."
self mergeGlyphs: model selected asOrderedCollection.!
moveToFront
"Move the currently selected glyphs to the front, in front of other glyphs."
(model selected asOrderedCollection) do:
[: glyph | model moveToFront: glyph].
view displayScene.!
moveToRear
"Move the currently selected glyphs to the rear, behind other glyphs."
(model selected asOrderedCollection) do:
[: glyph | model moveToRear: glyph].
view displayScene.!
operate
running _ true.!
scroll
"Wait for the mouse button to be pressed, then scroll."
Cursor hand showWhile: [sensor waitButton].
self scrollAt: sensor cursorPoint.!
selectAll
"Select all selectable glyphs."
model clearSelection.
model selectableGlyphsDo: [: g | model select: g].
view displayScene.!
selectArea
"Select everything in a rectangular area specified using the mouse. If the shift key is down, toggle select everything in the area."
"Remove all alignment constraints from the selected glyphs."
model selected do:
[: glyph |
glyph varsDo:
[: var |
var constraints copy do:
[: c |
(c isLayoutConstraint) ifTrue:
[c destroyConstraint]]]].!
unequate
"Remove all user-added equality constraints between the selected glyphs. If exactly two glyphs are selected, then the interesection of their set of user-added constraints is removed."
| selected equalitiesOnFirst |
selected _ model selected asOrderedCollection.
(selected size = 2)
ifTrue: "exactly two selected glyphs"
[equalitiesOnFirst _ IdentitySet new.
(selected first) varsDo:
[: var |
var constraints copy do:
[: c |
(c isUserConstraint) ifTrue:
[equalitiesOnFirst add: c]]].
(selected last) varsDo:
[: var |
var constraints copy do:
[: c |
((c isUserConstraint) and:
[equalitiesOnFirst includes: c]) ifTrue:
[c destroyConstraint]]]]
ifFalse: "arbitrary number of selected glyphs"
[selected do:
[: glyph |
glyph varsDo:
[: var |
var constraints copy do:
[: c |
(c isUserConstraint) ifTrue:
[c destroyConstraint]]]]]!
unmerge
"Extract the selected items from any merges in which they participate."
model selected do:
[: glyph | glyph extractFromMerge].
view computeEnclosingRectangle.
view displayScene.! !
!SceneController methodsFor: 'menu support'!
addAndPlace: newGlyph
"Add the given new glyph and let the user place it."
| refPoint |
model addGlyph: newGlyph.
refPoint _ sensor cursorPoint.
newGlyph moveTo: self adjustedCursorPoint.
self
while: [sensor anyButtonPressed not]
move: (newGlyph locationPoints)
refPoint: refPoint
mergeWith: nil.!
argument
"Answer the argument for unary operation from the model's selection. There must be exactly one object selected. If so, answer it. Otherwise, answer nil."
"Merge the glyphs in the given OrderedCollection, if they can be merged. The first glyph is the sink with which the remaining glyphs are merged."
| sink |
sink _ glyphsToMerge removeFirst.
glyphsToMerge do:
[: glyph |
(glyph canMergeWith: sink) ifTrue:
[glyph mergeWith: sink]].
view computeEnclosingRectangle.
view displayScene.!
partsMenu
"Answer a hierarchical menu of glyph categories and glyphs."
"Details: Building hierarchical menus is expensive, so we cache the menu and only rebuild it when a new glyph class is added or when the category of a glyph is changed."
"As the user moves the cursor, draw a selection rectangle, scrolling if the mouse leaves my view. When the red button is released, select all selectable glyphs inside the selection rectangle."
| origin selectionRect viewForm doneOnce point corner |
"Select the glyph at aPoint. If toggleFlag is true, add/remove the glyph to/from the selection. Otherwise add the glyph. If aPoint is not over any glyph then clear the selection."
| glyph |
glyph _ self glyphAt: aPoint.
(glyph notNil)
ifTrue:
[((model selected includes: glyph) not & toggleFlag not)
'I parse a ConcertWare 4.0 music file to produce a Score. Various printing attributes (such as stem direction, beaming, and slurs) are thrown away, as is any text underlay. Repeat structure is currently ignored.
I could be modified to work with other versions of ConcertWare. I seem to work with ConcertWare 5.0 files that do not use certain new features.'!
["the last note is slurred, not tied, to this note"
merger add: lastNote]].
((cmd bitAnd: 96) > 0)
ifTrue:
["this note is slurred or tied to the next note"
lastNote _ note]
ifFalse:
["this note is NOT slurred or tied to the next note"
merger add: note.
lastNote _ nil].
lastDur _ note dur].
time _ time + dur.!
readVoice
"Parse the notes of a voice, adding them the merge sorter."
time _ 0.
lastNote _ nil.
lastDur _ nil.
doneFlag _ false.
merger startNewSublist.
[doneFlag] whileFalse:
[self readCommand].!
skipHeader
"Skip the header of a ConcertWare 4.0 file."
| version count |
"check the version number, then skip the rest of the 56-byte fixed-size header"
version _ inStream next: 4.
(version asString = '4.01') ifFalse:
[self error: 'Cannot read files produced by that version of ConcertWare'].
inStream skip: 52.
"skip variable-length fields"
12 timesRepeat:
[self skipVariableLength].
"skip ruler record"
inStream skip: 64.!
skipText
"Skip a text record. A text record consists of a fifteen-byte fixed header followed by a string length byte followed by a string padded so as to make the total record length be even."
| count |
inStream skip: 15.
count _ inStream next.
inStream skip: count.
(count even) ifTrue: [inStream next]. "make total record length even"!
skipVariableLength
"Skip a variable length record. The first byte is the byte count of the remainder of the record."
| count |
count _ inStream next.
inStream skip: count.! !
!ThreeDPoint methodsFor: 'all'!
addStays
x defaultStay.
y defaultStay.
z defaultStay.!
equals: aThreeDPoint
x requireEquals: aThreeDPoint xVar.
y requireEquals: aThreeDPoint yVar.
z requireEquals: aThreeDPoint zVar.!
initialize
x _ FreeVariable value: 0.
y _ FreeVariable value: 0.
z _ FreeVariable value: 0.!
x: xValue y: yValue z: zValue
x setValue: xValue.
y setValue: yValue.
z setValue: zValue.!
xVar
^x!
yVar
^y!
zVar
^z! !
!PopUpMenu methodsFor: 'controlling'!
startUpWithHeadingAndWaitForSelection: aString
"Display and make a selection from the receiver as long as the button denoted
by the symbol, aSymbol, is pressed. Answer the current selection."
'I am used to build menus on-the-fly. I maintain lists of menu items, actions (usually symbols to be sent as messages), and menu section dividing lines to which my clients may append new entries and lines by sending me the messages:
add: aString action: anAction
addLine
After the menu is constructed, it may be invoked with one of the following messages:
invoke: initialSelection
invoke
I am a subclass of ActionMenu, so I inherit a number of instance variables. The ones I am particularly concerned with are:
items _ an OrderedCollection of strings to appear in the menu
selectors _ an OrderedCollection of Symbols to be used as message selectors
lineArray _ an OrderedCollection of line positions
lastLine _ used to keep track of the last line to avoid making duplicate entries in lineArray'!
!CustomMenu methodsFor: 'initialize-release'!
initialize
items _ OrderedCollection new.
selectors _ OrderedCollection new.
lineArray _ OrderedCollection new.
lastLine _ 0.! !
!CustomMenu methodsFor: 'construction'!
add: aString action: aSymbol
"Add the given string as the next menu item. If it is selected, the given action (usually but not necessarily a symbol) will be returned to the client."
items addLast: aString.
selectors addLast: aSymbol.!
addLine
"Append a line to the menu after the last entry. Suppress duplicate lines."
(lastLine ~= items size)
ifTrue:
[lastLine _ items size.
lineArray addLast: lastLine].! !
!CustomMenu methodsFor: 'invocation'!
invoke
"Invoke the menu with no initial selection."
^self invoke: nil!
invoke: initialSelection
"Invoke the menu with the given initial selection (i.e. one of my 'action' symbols). Answer the 'action' selector associated with the menu item chosen by the user or nil if none is chosen."
"Pre-select and highlight the menu item associated with the given action."
| i |
i _ selectors indexOf: action ifAbsent: [^self].
self reset.
marker _ marker
align: marker topLeft
with: (marker left)@(frame inside top + (marker height * (i - 1))).
selection _ i.! !
Strength comment:
'Strengths are used to measure the relative importance of constraints. The hierarchy of available strengths is determined by the class variable StrengthTable (see my class initialization method). Because Strengths are invariant, references to Strength instances are shared (i.e. all references to "Strength of: #required" point to a single, shared instance). New strengths may be inserted in the strength hierarchy without disrupting current constraints.'!
!Strength methodsFor: 'comparing'!
sameAs: aStrength
"Answer true if I am the same strength as the given Strength."
^arithmeticValue = aStrength arithmeticValue!
stronger: aStrength
"Answer true if I am stronger than the given Strength."
^arithmeticValue < aStrength arithmeticValue!
weaker: aStrength
"Answer true if I am weaker than the given Strength."
^arithmeticValue > aStrength arithmeticValue! !
!Strength methodsFor: 'max/min'!
strongest: aStrength
"Answer the stronger of myself and aStrength."
(aStrength stronger: self)
ifTrue: [^aStrength]
ifFalse: [^self].!
weakest: aStrength
"Answer the weaker of myself and aStrength."
(aStrength weaker: self)
ifTrue: [^aStrength]
ifFalse: [^self].! !
!Strength methodsFor: 'printing'!
printOn: aStream
"Append a string which represents my strength onto aStream."
aStream nextPutAll: '%', symbolicValue, '%'.! !
!Strength methodsFor: 'private'!
arithmeticValue
"Answer my arithmetic value. Used for comparisons. Note that STRONGER constraints have SMALLER arithmetic values."
^arithmeticValue!
initializeWith: symVal
"Record my symbolic value and reset my arithmetic value."
symbolicValue _ symVal.
self resetValue.!
initializeWith: symVal and: numVal
symbolicValue _ symVal.
arithmeticValue _ numVal!
resetValue
"Lookup my symbolic value in the StrengthTable and reset my internal value."
"This line drawing method was improved by John Maloney to do more intelligent clipping. If the line (p1,p2) is entirely INSIDE the clipping box, this method gives results that are identical to the original line drawing method. If the line is entirely OUTSIDE the clipping box, it detects this early and avoids the cost of drawing it. Finally, if the line is PARTIALLY inside the clipping box, the portion entirely inside the clipping box computed and can be drawn by the primitive. If the pen form is large, you may notice a slight difference from the results given by the normal drawFrom:to: method on the right/bottom of the clipping box."
"The clipping rectangle specified by the sender is intersected with the destination form. Then the corner of the result is inset by the extent of the pen form. This clipping rectangle is used to compute 'clippedLine'. clipped line is a triple <visibleFlag, startPoint, endPoint>. If visibleFlag is false, no part of the line is visible in the clipping box. If visibleFlag is true, clippedLine can be drawn with the primitive, which is fast."
'I support simple buttons. I have a Form for displaying myself and set of client-supplied blocks for performing actions on button down, button up, and abort (mouse up outside the button).'!
!PaletteButton methodsFor: 'initialize-release'!
form: aForm position: aPoint
form _ aForm.
position _ aPoint.
view _ nil. "The view must be initialized before this button can be used."
downAction _ whileDownAction _ [].
commitAction _ abortAction _ [].
activeTest _ [true].
onTest _ [false].!
release
form _ nil.
position _ nil.
view _ nil.
downAction _ whileDownAction _ nil.
commitAction _ abortAction _ nil.
activeTest _ onTest _ nil.! !
!PaletteButton methodsFor: 'access'!
abortAction: aBlock
abortAction _ aBlock.!
absolutePosition
^view insetDisplayBox origin + position!
activeTest: aBlock
activeTest _ aBlock.!
commitAction: aBlock
commitAction _ aBlock.!
downAction: aBlock
downAction _ aBlock.!
form: aForm
form _ form.!
onTest: aBlock
onTest _ aBlock.!
view: aView
view _ aView.!
whileDownAction: aBlock
whileDownAction _ aBlock.! !
!PaletteButton methodsFor: 'operation'!
display
"Display myself, taking into account my state (active/non-active, on/off)."
| box where |
box _ view insetDisplayBox.
where _ self absolutePosition.
(activeTest value) ifFalse:
[form
displayOn: Display at: where clippingBox: box
rule: Form over mask: Form gray].
form
displayOn: Display at: where clippingBox: box
rule: Form over mask: Form black.
(onTest value) ifTrue:
[Display reverse:
((form computeBoundingBox expandBy: -1)
translateBy: where)].!
hasCursor
"Answer true if I contain the cursor."
^form computeBoundingBox containsPoint:
(Sensor cursorPoint - self absolutePosition)!
respond
"Respond and answer true if the mouse button goes up over me."
((activeTest value) and: [self hasCursor])
ifFalse: [^false]. "not active or cursor not over me"
self showResponse. "assume I am visible"
downAction value.
[Sensor anyButtonPressed]
whileTrue:
[whileDownAction value.
(self hasCursor) ifFalse:
[abortAction value.
self showResponse.
self display.
^false]].
commitAction value.
self showResponse.
self display.
^true!
showResponse
"Display feedback indicating that I have been pressed. Assume that I am entirely visible (don't bother with clipping)."
Display
border: ((form computeBoundingBox expandBy: 2)
translateBy: self absolutePosition)
width: 2
rule: Form reverse
mask: Form black.! !
Planner comment:
'I embody the DeltaBlue algorithm described in:
"The DeltaBlue Algorithm: An Incremental Constraint Hierarchy Solver"
by Bjorn N. Freeman-Benson and John Maloney
See January 1990 Communications of the ACM or University of Washington TR 89-08-06 for further details.'!
!ThreeDDemo methodsFor: 'all'!
cube
"Answer a set variable containing the ThreeDLines comprising a cube."
'I represent a system-maintainable relationship (or "constraint") between a set of variables. I contain a set of methods that can be executed to enforce the constraint. If I am satisfied in the current data flow graph, the method used to enforce the relationship is stored in whichMethod. If I am not satisfied, whichMethod is nil.
Instance variables:
strength the strength of this constraint <Strength>
variables the constrained variables <Array of DBVariable>
methods a collection of methods that can be used to
enforce this constraint <Array of Method>
whichMethod the method currently used to enforce this constraint
or nil if this constraint is not satisfied <Method>'!
!AbstractConstraint methodsFor: 'accessing'!
name: n
name _ n!
strength
"Answer my strength."
^strength!
strength: strengthSymbol
"Set my strength."
strength _ Strength of: strengthSymbol.! !
!AbstractConstraint methodsFor: 'queries'!
includeInPlan
"Answer true if this constraint should be included in the plan. Subclasses such as EditConstraint and StayConstraint override this method to return 'false', since they are noops at plan execution time."
^true!
isInput
"Normal constraints are not input constraints. An input constraint is one that depends on external state, such as the mouse, the keyboard, a clock, or some arbitrary piece of imperative code."
^false!
isLayoutConstraint
"Normal constraints are not layout constraints."
^false!
isMergeConstraint
"Normal constraints are not merge constraints."
^false!
isRequired
"Answer true if this constraint is a required constraint."
^strength sameAs: (Strength required)!
isSatisfied
"Answer true if this constraint is satisfied in the current solution."
self subclassResponsibility!
isUserConstraint
"Normal constraints are not user constraints."
^false! !
!AbstractConstraint methodsFor: 'add/remove'!
addConstraint
"Activate this constraint and attempt to satisfy it."
self addToGraph.
Planner incrementalAdd: self.!
addToGraph
"Add myself to the constraint graph."
self subclassResponsibility!
destroyConstraint
"Remove and release the constraint."
self removeConstraint.
self release.!
removeConstraint
"Deactivate this constraint and remove it from the constraint graph, possibly causing other constraints to be satisfied."
name notNil ifTrue: [aStream nextPutAll: ' "', name, '"'].
aStream nextPut: $)! !
!AbstractConstraint methodsFor: 'planning'!
chooseMethod: mark
"Decide if I can be satisfied and record that decision. The output of the choosen method must be not have the given mark and must have a walkabout strength less than that of this constraint."
self subclassResponsibility!
inputsDo: aBlock
"Assume that I am satisfied. Evaluate the given block on all my current input variables."
self subclassResponsibility!
inputsKnown: mark
"Assume that I am satisfied. Answer true if all my current inputs are known. A variable is known if either a) it is 'stay' (i.e. it is a constant at plan execution time), b) it has the given mark (indicating that it has been computed by a constraint appearing earlier in the plan), or c) it is not determined by any constraint. The last provision is for past states of history variables, which are not marked stay but which do not depend on any constraint being already in the plan."
"Answer my current output variable. Raise an error if I am not currently satisfied."
self subclassResponsibility!
possibleMethodsDo: aBlock
"Evaluate the given block for all potential methods of this constraint. The block takes two arguments. The first is a list of inputs for the method. The second is the output for the method."
self subclassResponsibility!
recalculate
"Calculate the walkabout strength, the stay flag, and, if it is 'stay', the value for the current output of this constraint, and answer the current output variable. Assume this constraint is satisfied."
self subclassResponsibility!
satisfy: mark
"Attempt to find a way to enforce this constraint. If successful, record the solution, perhaps modifying the current dataflow graph. Answer the constraint that this constraint overrides, if there is one, or nil, if there isn't."
"Assume: I am not already satisfied"
| overridden out |
self chooseMethod: mark.
(self isSatisfied)
ifTrue: "constraint can be satisfied"
["mark inputs to allow cycle detection in addPropagate"
[self notify: 'Failed to satisfy a required constraint']].
^overridden! !
!AbstractConstraint methodsFor: 'execution'!
codeStringFor: variableDictionary on: aStream
"Append to the given stream a Smalltalk string that can be compiled to enforce this constraint. variableDictionary is a Dictionary mapping each constrained variable to a string to be used to reference that variable."
self error: 'This constraint cannot be compiled'!
execute
"Enforce this constraint. Assume that it is satisfied."
self subclassResponsibility! !
Constraint comment:
'I represent a system-maintainable relationship (or "constraint") between a set of variables. I contain a set of methods that can be executed to enforce the constraint. If I am satisfied in the current data flow graph, the method used to enforce the relationship is stored in whichMethod. If I am not satisfied, whichMethod is nil.
Instance variables:
strength the strength of this constraint <Strength>
variables the constrained variables <Array of DBVariable>
methods a collection of methods that can be used to
enforce this constraint <Array of Method>
whichMethod the method currently used to enforce this constraint
or nil if this constraint is not satisfied <Method>'!
!Constraint methodsFor: 'initialize-release'!
methods: methodList
"Initialize myself with the given methods. I am initially not bound to variables."
strength _ Strength required.
methods _ methodList asArray.
whichMethod _ nil.!
release
strength _ nil.
methods _ nil.
whichMethod _ nil.!
var: variable strength: strengthSymbol
"Install myself on the given variable with the given strength."
"Install myself on the given collection of variables with the given strength."
(vars size == self size) ifFalse:
[self error: 'Wrong number of variables for this constraint.'].
1 to: self size do:
[: i | self at: i put: (vars at: i)].
strength _ Strength of: aSymbol.
self addConstraint.! !
!Constraint methodsFor: 'queries'!
isSatisfied
"Answer true if this constraint is satisfied in the current solution."
^whichMethod notNil! !
!Constraint methodsFor: 'add/remove'!
addToGraph
"Add myself to the constraint graph."
1 to: self size do:
[: i | (self at: i) addConstraint: self].
whichMethod _ nil.!
removeFromGraph
"Remove myself from the constraint graph."
| v |
1 to: self size do:
[: i |
v _ self at: i.
(v == nil) ifFalse: [v removeConstraint: self]].
whichMethod _ nil.! !
!Constraint methodsFor: 'planning'!
chooseMethod: mark
"Decide if I can be satisfied and record that decision. The output of the choosen method must be not have the given mark and must have a walkabout strength less than that of this constraint."
"Evaluate the given block for all potential methods of this constraint. The block takes two arguments. The first is a list of inputs for the method. The second is the output for the method."
| outIndex ins |
methods do:
[: m |
outIndex _ m outIndex.
ins _ OrderedCollection new: self size.
1 to: self size do:
[: i | (i == outIndex) ifFalse: [ins add: (self at: i)]].
aBlock value: ins value: (self at: outIndex)].!
recalculate
"Calculate the walkabout strength, the stay flag, and, if it is 'stay', the value for the current output of this constraint, and answer the current output variable. Assume this constraint is satisfied."
"Evaluate the given block on all my current input variables."
cluster springs do:
[: spring |
aBlock value: spring p1 xVar last.
aBlock value: spring p1 yVar last.
aBlock value: spring p2 xVar last.
aBlock value: spring p2 yVar last.
aBlock value: spring forceVar last].
cluster vectors do:
[: vector |
aBlock value: vector p1 xVar last.
aBlock value: vector p1 yVar last.
aBlock value: vector p2 xVar last.
aBlock value: vector p2 yVar last].!
markUnsatisfied
"Record the fact that I am unsatisfied."
satisfied _ false.!
output
"Answer my output variable."
^output!
possibleMethodsDo: aBlock
"Evaluate the given block for all potential methods of this constraint. The block takes two arguments. The first is a list of inputs for the method. The second is the output for the method."
"Decide if I can be satisfied and record that decision."
satisfied _
(out mark ~= mark) and:
[strength stronger: out walkStrength].!
execute
"Enforce this constraint. Assume that it is satisfied."
self subclassResponsibility!
inputsDo: aBlock
"Evaluate the given block on my input variables."
aBlock value: v1.
aBlock value: v2.!
markUnsatisfied
"Record the fact that I am unsatisfied."
satisfied _ false.!
output
"Answer my output variable."
^out!
possibleMethodsDo: aBlock
"Evaluate the given block for all potential methods of this constraint. The block takes two arguments. The first is a list of inputs for the method. The second is the output for the method."
"Calculate the walkabout strength, the stay flag, and, if it is 'stay', the value for the current output of this constraint, and answer the output variable. Assume this constraint is satisfied."
"Decide if I can be satisfied and record that decision."
satisfied _
(output mark ~= mark) and:
[strength stronger: output walkStrength].!
execute
"Enforce this constraint. Assume that it is satisfied."
self subclassResponsibility!
inputsDo: aBlock
"I have no input variables."!
markUnsatisfied
"Record the fact that I am unsatisfied."
satisfied _ false.!
output
"Answer my current output variable."
^output!
possibleMethodsDo: aBlock
"Evaluate the given block for all potential methods of this constraint. The block takes two arguments. The first is a list of inputs for the method. The second is the output for the method."
aBlock value: #() value: output.!
recalculate
"Calculate the walkabout strength, the stay flag, and, if it is 'stay', the value for the current output of this constraint, and answer the output variable. Assume this constraint is satisfied."
output walkStrength: strength.
(self isInput)
ifTrue:
[output stay: false]
ifFalse:
[output stay: true.
self execute]. "stay optimization"
^output! !
StayConstraint comment:
'I mark variables that should, with some level of preference, stay the same. I have one method with zero inputs and one output, which does nothing. Planners may exploit the fact that, if I am satisfied, my output will not change during plan execution. This is called "stay optimization."'!
!StayConstraint methodsFor: 'queries'!
includeInPlan
"Stay constraints have no effect other than to control the planning process."
^false! !
!StayConstraint methodsFor: 'execution'!
codeStringFor: vars on: aStream
"Stay constraints do nothing."!
execute
"Stay constraints do nothing."! !
EditConstraint comment:
'I am used to mark a variable that the user wishes to edit. I have one method with zero inputs and one output, which does nothing.'!
!EditConstraint methodsFor: 'queries'!
includeInPlan
"Edit constraints have no effect other than to control the planning process."
^false!
isInput
"I indicate that a variable is to be changed by imperative code."
^true! !
!EditConstraint methodsFor: 'execution'!
codeStringFor: vars on: aStream
"Edit constraints do nothing."!
execute
"Edit constraints do nothing."! !
XMouseConstraint comment:
'I am an input constraint that relates a variable to the current x-coordinate of the mouse. I contain an offset to normalize the coordinate system to one convenient for the target variable. I have one method with zero inputs and one output.'!
"Enforce this constraint. Assume that it is satisfied."
output value: (Sensor mousePoint x + xOffset).! !
YMouseConstraint comment:
'I am an input constraint that relates a variable to the current y-coordinate of the mouse. I contain an offset to normalize the coordinate system to one convenient for the target variable. I have one method with zero inputs and one output.'!
"Initialize myself with the given variables and strength."
strength _ Strength of: strengthSymbol.
v1 _ variable1.
v2 _ variable2.
direction _ nil.
((v1 notNil) & (v2 notNil)) ifTrue:
[self addConstraint].! !
!BinaryConstraint methodsFor: 'queries'!
isSatisfied
"Answer true if this constraint is satisfied in the current solution."
^direction notNil! !
!BinaryConstraint methodsFor: 'add/remove'!
addToGraph
"Add myself to the constraint graph."
v1 addConstraint: self.
v2 addConstraint: self.
direction _ nil.!
removeFromGraph
"Remove myself from the constraint graph."
(v1 == nil) ifFalse: [v1 removeConstraint: self].
(v2 == nil) ifFalse: [v2 removeConstraint: self].
direction _ nil.! !
!BinaryConstraint methodsFor: 'planning'!
chooseMethod: mark
"Decide which way I should flow based on the relative strength of the variables I relate and record that decision."
(v1 mark == mark) ifTrue: "forward or nothing"
[((v2 mark ~= mark) and: [strength stronger: v2 walkStrength])
ifTrue: [^direction _ #forward]
ifFalse: [^direction _ nil]].
(v2 mark == mark) ifTrue: "backward or nothing"
[((v1 mark ~= mark) and: [strength stronger: v1 walkStrength])
ifTrue: [^direction _ #backward]
ifFalse: [^direction _ nil]].
"if we get here, neither variable is marked, so we have choice"
(v1 walkStrength weaker: v2 walkStrength)
ifTrue:
[(strength stronger: v1 walkStrength)
ifTrue: [^direction _ #backward]
ifFalse: [^direction _ nil]]
ifFalse:
[(strength stronger: v2 walkStrength)
ifTrue: [^direction _ #forward]
ifFalse: [^direction _ nil]].!
execute
"Enforce this constraint. Assume that it is satisfied."
self subclassResponsibility!
inputsDo: aBlock
"Evaluate the given block on my current input variable."
(direction == #forward)
ifTrue: [aBlock value: v1]
ifFalse: [aBlock value: v2].!
markUnsatisfied
"Record the fact that I am unsatisfied."
direction _ nil.!
output
"Answer my current output variable."
(direction == #forward)
ifTrue: [^v2]
ifFalse: [^v1]!
possibleMethodsDo: aBlock
"Evaluate the given block for all potential methods of this constraint. The block takes two arguments. The first is a list of inputs for the method. The second is the output for the method."
aBlock value: (Array with: v1) value: v2.
aBlock value: (Array with: v2) value: v1.!
recalculate
"Calculate the walkabout strength, the stay flag, and, if it is 'stay', the value for the current output of this constraint, and answer the output variable. Assume this constraint is satisfied."
| in out |
(direction == #forward)
ifTrue: [in _ v1. out _ v2]
ifFalse: [out _ v1. in _ v2].
out walkStrength: (strength weakest: in walkStrength).
(in stay)
ifTrue:
[out stay: true.
self execute] "stay optimization"
ifFalse:
[out stay: false].
^out! !
OffsetConstraint comment:
'I relate two variables by a fixed offset: "v1 + offset = v2".'!
"Evaluate the given block for all potential methods of this constraint. The block takes two arguments. The first is a list of inputs for the method. The second is the output for the method."
"Calculate the walkabout strength, the stay flag, and, if it is 'stay', the value for the current output of this constraint, and answer the output variable. Assume this constraint is satisfied."
| in out |
(direction == #forward)
ifTrue: [in _ v1. out _ v2]
ifFalse: [out _ v1. in _ v2].
out walkStrength: (strength weakest: in walkStrength).
'I am a parser for the Adagio score representation language as described in the CMU Midi Toolkit handbook. I am invoked by "AdagioParser parse: stream" where the stream typically comes from a string or file. I am driven by a table of token types, TypeTable. (This table is defined in my class initialization message.) I work by collecting note attributes and flags until a delimiter is reached, at which point I output a note and update the current time according to the current set of attributes. Delimiters are comma, semi-colon, and the end of a line. Please see the description of the Adagio language in the CMU Midi Toolkit handbook for further details.'!
!AdagioParser methodsFor: 'initialize-release'!
initAdagioDefaults
"Initialize all Adagio state variables to their default values."
tempo _ 100.0.
rate _ 100.0.
synchPoint _ 0.0.
time _ 0.0.
duration _ DurationsTable at: $q.
nextTimeDelta _ nil.
pitchClass _ PitchTable at: $c.
modifier _ 0.
octave _ 4.
loudness _ 127.
voice _ 1.
timbre _ 1.
restFlag _ false.
hadAttributeFlag _ false.!
parse: aStream
"Parse the Adagio score in aStream and answer the resulting Score object."
typeTable _ AdagioTypeTable.
source _ aStream.
buffer _ BufferStream on: (String new: 40).
self nextChar. "prime the pump"
notes _ MergeSorter new.
self initAdagioDefaults.
[self doNext] whileFalse: []. "parse until done"
^notes asScore! !
!AdagioParser methodsFor: 'attribute parsing'!
parseDur
"Parse the symbolic duration contained in buffer (e.g. 'q.t' is a dotted quarter triplet). Answer the duration in 100ths of a second if this succeeds, answer nil if it fails."
"Parses a next time attribute. The next time value may be a positive number or it may be a symbolic duration. For example, 'n60' = 'nq' at a tempo of 100; both cause the next note to be played a quarter note amount of time after the current note, or 60/100ths of a second."
"Sets a flag indicating that this was a rest. This flag suppresses generation of a note, although other attributes such as voice, timbre, and time are updated."
| restCmd |
self scanAttribute.
restCmd _ self token.
((restCmd = 'r') or: [restCmd = 'R'])
ifFalse: [^self badAttribute].
hadAttributeFlag _ restFlag _ true.!
xSpecial
"Parses an Adagio special command. Special commands start with an exclaimation point (!!) and may not be combined on a line with other attributes."
| cmd |
self scanAttribute.
cmd _ self token.
(cmd = '!!tempo') ifTrue: [^self parseTempo].
(cmd = '!!rate') ifTrue: [^self parseRate].
(cmd = '!!endscore')
ifTrue:
[hadAttributeFlag _ false.
tokenType _ #end.
^source setToEnd].
"unknown special command"
self error: 'bad special command', cmd.
self specialCheck.!
xTime
"Parses a time attribute. The time may be a positive number or it may be a symbolic duration. For example, 't60' = 'tq' at a tempo of 100; both cause the time to be set to one quarter note, or 60/100ths of a second, after the last synch point."
"Parses a voice attribute (e.g. 'v3' sets the current voice to 3)."
| v |
self scanAttribute.
buffer next.
(buffer atEnd) ifTrue: [^self badAttribute].
v _ self convertToNumber: buffer posOnly: true.
(v isNil)
ifTrue: [^self]. "bad number; abort"
(v < 1) ifTrue:
[self range: 'voice' value: v using: 1.
v _ 1].
(v > 16) ifTrue:
[self range: 'voice' value: v using: 16.
v _ 16].
voice _ v.
hadAttributeFlag _ true.! !
!AdagioParser methodsFor: 'scanning'!
nextChar
"Read the next character of the source into hereChar. hereChar is set to EndChar when the source is exhausted."
(hereChar _ source next) isNil
ifTrue: [hereChar _ StopChar].!
nextToken
"Read the next token from source, which is determined by looking at the first non-white space character. Set tokenType to indicate the type of the token just read."
self skipWhiteSpace.
tokenType _ typeTable at: hereChar asciiValue.
"if x is the first letter of tokenType:"
(tokenType at: 1) == $x
ifTrue:
["then perform it to scan a note attribute token"
self perform: tokenType]
ifFalse:
["else this tokenType needs no further processing"
self nextChar].!
peekAhead
"Skip white space and peek at the type of the next character type."
self skipWhiteSpace.
^typeTable at: hereChar asciiValue!
scanAttribute
"Read a string of contiguous characters not containing spaces or delimiters."
^nil]. "return nil to indicate an error even if the user proceeds"
^val!
curDuration
"A tempo of 100 means 100 quarter notes per minute, or 60 hundredths of a second per quarter note. A duration must be scaled by both the tempo and the rate. A rate of '100' is normal, '200' is twice normal, etc. If the rate is doubled, the duration of each note must be cut in half."
^duration * (100.0 / tempo) * (100.0 / rate)!
curPitch
^(octave + 1) * 12 + pitchClass + modifier!
doNext
"Scan the next token from the input and take appropriate action. Answer true when input is exhausted."
self nextToken. "sets tokenType"
(tokenType == #attribute) ifTrue:
[^false].
(tokenType == #separator) ifTrue:
["Generate an event and advance time."
self generateEvent: true.
^false].
(tokenType == #semicolon) ifTrue:
["Generate an event and advance time."
self generateEvent: true.
^false].
(tokenType == #comma) ifTrue:
["Generate an event but do not advance time (comma separator)."
self generateEvent: false.
^false].
(tokenType == #xComment) ifTrue:
[^false].
(tokenType == #end) ifTrue:
[self generateEvent: false. "Generate the last event. Don't bother advancing time."
^true].
"if we get here, we have encountered an unexpected character"
self report: 'Unexpected character ', hereChar asciiValue printString.
self skipRestOfLine.!
generateEvent: advanceFlag
| note |
hadAttributeFlag ifTrue:
[restFlag ifFalse:
[note _ NoteElement
new: (self curPitch)
at: (time truncated)
dur: (self curDuration truncated)
vel: loudness
voice: voice.
notes add: note].
(nextTimeDelta notNil)
ifTrue:
["always advance time if a nextTimeDelta attribute was given"
time _ time + nextTimeDelta.
nextTimeDelta _ nil]
ifFalse:
["advance time even if nextTimeDelta wasn't given, using the duration of the current note"
advanceFlag ifTrue: [time _ time + self curDuration]]].
"Special commands cannot be combined with other attributes. This method is to be called after parsing the arguments of a special command to be sure that no other attributes occur before the next separator."
[(self peekAhead == #separator) or:
[self peekAhead == #end]]
whileFalse:
[self skipWhiteSpace.
self scanAttribute.
self error: 'Attributes not allowed with special commands', self token].!
token
^buffer contents! !
PitchRider comment:
'See my class comment.'!
MidiRecorder comment:
'I am a recorder for Midi events. I can be used to record a score in real time. I can also overdub (record a new score while playing an existing one), monitor incoming Midi commands (either as raw bytes or as higher level commands), or support interactive performance (in which the computer performs in response to incoming Midi commands).
Midi controllers such as pitch benders and breath controllers generate large volumes of data which consume processor time. In cases where this information is not of interest to the program using it, it is best to filter it out as soon as possible. I support various options for doing this including filtering by Midi channel and/or by command type.'!
!MidiRecorder methodsFor: 'initialize-release'!
reset
"Reset to a state of being ready to record Midi events."
(times isNil)
ifTrue:
[limit _ InitialSize.
times _ Array new: InitialSize.
cmds _ Array new: InitialSize.
arg1s _ Array new: InitialSize.
arg2s _ Array new: InitialSize]
ifFalse:
[1 to: limit do:
[: index |
times at: index put: nil.
cmds at: index put: nil.
arg1s at: index put: nil.
arg2s at: index put: nil].
].
next _ 1.
state _ #idle.
lastCmd _ nil.
lastSelector _ nil.
activeNotes _ nil.
pedalNotes _ nil.
inBuf _ ByteArray new: 4.!
resetMidiTable
"Resets the Midi table to default table from my class."
"Print midi messages to the transcript until any mouse button is pressed."
self midiDo: [: cmd : arg1 : arg2 |
self printCmd: cmd with: arg1 with: arg2].!
pollMidi: aBlock
"Poll the incoming Midi stream in real time and call the given block for each Midi event. The block takes three arguments: the Midi command byte and two argument bytes. Depending on the command, the argument bytes may or may not be meaningful. It is up to the block to 'understand' Midi commands. See midiDo: for implementation details."
| mSecsAtStart i |
self recordData.
(state == #idle) ifFalse: [^self]. "wait for a better moment..."
"This test records your playing until a mouse button is pressed, then plays what you played back to you. Answers the recorded score."
"MidiRecorder new echoTest"
| score |
self reset.
score _ self record.
[Sensor anyButtonPressed] whileTrue: ["wait for button to be released"].
score playFrom: 0 rate: 1.
^score!
overDub: aScore
"Record a new score while performing aScore from the beginning at normal speed. Stop when a mouse button is pressed. Answer the newly recorded 'track'."
^self overDub: aScore playFrom: 0 rate: 1!
overDub: aScore playFrom: startTime
"Record a new score while performing aScore from the given starting point at normal speed. Stop when a mouse button is pressed. Answer the newly recorded 'track'."
"Record a new score while performing aScore from the given point at the given rate. Stop when a mouse button is pressed. Answer the newly recorded 'track'."
| mSecsAtStart currTime |
"ignore key after-pressure, program change, channel pressure (after-touch), and pitch wheel change commands:"
"Skip to the first note at or after the given time, processing all control changes and program changes along the way to establish the proper synthesizer state."
"Interact with the incoming Midi stream in real time by calling the given block for each Midi event. The block takes three arguments: the Midi command byte and two argument bytes. Depending on the command, the argument bytes may or may not be meaningful. It is up to the block to 'understand' Midi commands. As usual, pressing any mouse button terminates the interaction."
"Details: Set ourselves up to record as usual, but every time through the loop print the next command in the recording buffers. If the printing process catches up to the 'record head' (next), and we are in an idle state, reset the record head and i to the beginning."
"Convert the absolute time in ticks to time since start of recording for all recorded events. If absFlag is true, then times are absolute. Otherwise, the starting time of the first recorded event is taken to be time zero."
times at: index put: ((times at: index) - timeAtStart).
((cmds at: index) == #stop) ifTrue: [^self]].!
convertTimes: absFlag rate: rate
"Convert the absolute time in ticks to time since start of recording for all recorded events. If absFlag is true, then times are absolute. Otherwise, the starting time of the first recorded event is taken to be time zero."
'A Plan is a list of constraints to be executed in sequence to re-satisfy all currently satisfiable constraints in the face of one or more changing inputs.'!
!Plan methodsFor: 'initialize-release'!
initialize
constraints _ OrderedCollection new: 2000.
historyVariables _ OrderedCollection new: 2000.!
release
constraints _ nil.
historyVariables _ nil.! !
!Plan methodsFor: 'construction'!
append: aConstraint
"Append the given constraint to this plan. Record its output variable if it is a HistoryVariable."
"Details: The history variables of interest are those whose current state is changing. This can only happen if they are the output of some sort of constraint (including an input constraint). Furthermore, we only want to send the 'advanceHistory' message to the root of a history chain. This is guaranteed because only current states (roots) can be constraint outputs. Finally, edit and stay constraints are noops and are not recorded in the plan."
(aConstraint includeInPlan) ifTrue:
[constraints addLast: aConstraint].
(aConstraint output class == HistoryVariable) ifTrue:
[historyVariables add: aConstraint output].!
finalize
"Turn the constraint and historyVariables collections into Arrays for faster execution."
constraints _ constraints asArray.
historyVariables _ historyVariables asArray.! !
!Plan methodsFor: 'interpretation'!
execute
"Execute my constraints in order."
Sensor leftShiftDown ifTrue: [Transcript show: '*** executing plan ***'; cr].
historyVariables do: [:v | v advanceHistory].
constraints do:
[:c |
c execute.
Sensor leftShiftDown ifTrue: [Transcript show: c printString; cr]]!
size
^constraints size! !
!Plan methodsFor: 'compilation'!
compilePlan
"Compile a method to execute this plan."
| varDict codeStream |
"collect variables and make a dictionary mapping variables to reference strings"
varDict _ IdentityDictionary new.
constraints do:
[: c |
c inputsDo: [: input | self record: input in: varDict].
'I support line clipping using the standard algorithm (see, e.g., Foley and vanDam''s book on interactive graphics). If I have zero area (because my height or width is zero) then I will report that no lines intersect me.'!
!ClippingRectangle methodsFor: 'clipping'!
clipFrom: beginPoint to: endPoint
"Clip the line (beginPoint, endPoint) and answer an array of three elements, (drawFlag, clippedBegin, clippedEnd). If the first element of the answer is false, the line is completely outside the clipping rectangle, and need not be displayed. If the first element of answer is true, the second two elements are the beginning and ending points of the clipped line."
"If we haven't rejected the line by now, some of it must lie within the clipping rectangle. If u0 or u1 are within the open interval (0..1), use them to compute the new line segment start and/or point."
"Answer true if either my width or my height are zero."
^(xMin == xMax) | (yMin == yMax)! !
!ClippingRectangle methodsFor: 'private'!
clip: e delta: d
| r |
"Case 1: line parallel to boundary"
(d = 0) ifTrue: [^e >= 0]. "accept if e is on boundary or inside"
r _ e asFloat / d asFloat. "the normalized intersection with the boundary"
"Case 2: line from outside to inside"
(d < 0) ifTrue:
[(r > u1) ifTrue: [^false]. "reject"
u0 _ u0 max: r. "update u0 and accept"
^true].
"Case 3: line from inside to outside"
(d > 0) ifTrue:
[(r < u0) ifTrue: [^false]. "reject"
u1 _ u1 min: r. "update u1 and accept"
^true].!
clipOrigin: origin corner: corner
"This is the initialization message. corner should be >= origin, but if it isn't you will simply get an empty clipping rectangle."
xMin _ origin x.
yMin _ origin y.
xMax _ xMin max: corner x.
yMax _ yMin max: corner y.! !
Glyph comment:
'I am an abstract class that defines the protocol used by components of a Scene to permit them to be laid out, displayed, and selected. Subclasses of me must implement the methods specified as ''subclassResponsibility'' (which are currently only locationPoints and boundingBox, but don''t trust this comment!!).'!
!Glyph methodsFor: 'initialize-release'!
initialize
"Initialize myself with default values. Subclasses should do 'super initialize' when overriding this method to ensure that instance variables owned by their superclass are properly initialized."! !
!Glyph methodsFor: 'glyph protocol'!
boundingBox
"Answer a Rectangle that completely surrounds all visible parts of me. By default, this is the smallest rectangle enclosing all my location points."
| locations min max |
locations _ self locationPoints.
min _ max _ locations first.
locations do:
[: p |
min _ min min: p.
max _ max max: p].
^min corner: max!
changing
"Answer true if my appearance depends on a constrained variable that is not a constant at plan execution time."
"Draw myself. The default is to do nothing. Visible glyphs supply a more specialized behavior for this method."!
glyphsComment
"This protocol describes the basic operations on graphical objects known as 'glyphs'. A glyph may be displayed, selected, and moved. Glyphs may be hierarchically composed of other glyphs. For example, a LineGlyph might be built from two PointGlyphs. A higher-level glyph often makes the glyphs of its component parts available for display, selection, and input operations. However, sometimes a glyph hides some of its component glyphs or some aspect of the behavior of those glyphs, such as the ability to select them. Thus, there are different messages for enumerating the subglyphs of a glyph for various purposes. The default behavior of these operations is to simply enumerate all the subglyphs but any glyph my override this behavior to control the visibility of its subparts. The three categories of glyphs are:
1. visible glyphs -- glyphs that are visible in the display
2. selectable glyphs -- glyphs that can be selected and moved
3. input glyphs -- glyphs that respond to keyboard and/or mouse events
These categories are orthogonal, so it is possible to have visible glyphs that cannot be selected and moved or glyphs that can be selected but are not visible (such as the end points of a PlainLine).
All glyphs must respond to basic glyph protocol:
locationPoints -- Essential!!
displayOn:at:clip:
boundingBox
initialize
The only essential message is locationPoints; default behavior is provided for the other messages, although since the default displayOn:at:clip: behavior is to do nothing, a glyph that does not override this default will not be visible!!
If a glyph is an input glyph, it must also respond to one of:
wantsKeystrokes
wantsMouse
and, if it answers 'true' to one of these messages, it must support the corresponding keyboard and/or mouse prototcol."!
"Answer a collection of PointGlyphs that determine my location. These points are used to move the glyph."
self subclassResponsibility! !
!Glyph methodsFor: 'moving'!
center
| locations |
locations _ self locationPoints.
(locations size = 1)
ifTrue: [^locations at: 1]
ifFalse:
[^(locations
inject: 0@0
into: [: total : p | total + p]) // locations size].!
moveTo: aPoint
| locations center newLocations |
locations _ self locationPoints.
(locations size = 1) ifTrue: "easy case: one point"
[(locations at: 1) x: aPoint x; y: aPoint y.
^self].
center _ self center.
newLocations _ self locationPoints collect:
[: p | aPoint + (p - center)].
self locationPoints with: newLocations do:
[: p : newLocation |
p x: newLocation x.
p y: newLocation y].! !
!Glyph methodsFor: 'merging'!
canMergeWith: aGlyph
"Answer true if I can be merged with the given glyph. This is false by default. If this method answers 'true' then a method for 'mergeWith:' must also be provided."
^false!
extractFromMerge
"Remove all merge constraints from this glyph."
self varsDo:
[: var |
var constraints copy do:
[: c |
(c isMergeConstraint) ifTrue:
[c destroyConstraint]]].!
mergeWith: aGlyph
"Add equality constraints between significant parts of me and the given glyph. The subclass must override this method if 'canMergeWith:' may return true."
self subclassResponsibility! !
!Glyph methodsFor: 'enumeration'!
includesObjectIn: objectList
"Answer true if I include one of the given given objects as a subpart or if I am one of the given objects."
| i subPart |
(objectList includes: self) ifTrue: [^true].
"1 to: self class instSize do: [: i |"
i _ self class instSize.
[i > 0] whileTrue:
[subPart _ self instVarAt: i.
(objectList includes: subPart) ifTrue: [^true].
((subPart isGlyph) and:
[subPart includesObjectIn: objectList]) ifTrue:
[^true].
i _ i - 1].
^false!
inputGlyphsDo: aBlock
"Recursively enumerate the subparts of me that might want input."
| i subPart |
(self wantsKeystrokes | self wantsMouse) ifTrue:
[aBlock value: self].
"1 to: self class instSize do: [: i |"
i _ self class instSize.
[i > 0] whileTrue:
[subPart _ self instVarAt: i.
(subPart isGlyph) ifTrue:
[subPart inputGlyphsDo: aBlock].
i _ i - 1].!
selectableGlyphsDo: aBlock
"Recursively enumerate the selectable subparts of me."
| i subPart |
(self isSelectable) ifTrue: [aBlock value: self].
"1 to: self class instSize do: [: i |"
i _ self class instSize.
[i > 0] whileTrue:
[subPart _ self instVarAt: i.
(subPart isGlyph) ifTrue:
[subPart selectableGlyphsDo: aBlock].
i _ i - 1].!
varsDo: aBlock
"Invoke the given block on all constrained variables owned by me."
| i subPart |
"1 to: self class instSize do: [: i |"
i _ self class instSize.
[i > 0] whileTrue:
[subPart _ self instVarAt: i.
((subPart class == ConstrainedVariable) or: [subPart class == HistoryVariable]) ifTrue:
[aBlock value: subPart].
(subPart isGlyph) ifTrue:
[subPart varsDo: aBlock].
i _ i - 1].!
visibleGlyphsDo: aBlock
"Recursively enumerate the visible subparts of me."
| i subPart |
(self isVisible) ifTrue: [aBlock value: self].
"1 to: self class instSize do: [: i |"
i _ self class instSize.
[i > 0] whileTrue:
[subPart _ self instVarAt: i.
(subPart isGlyph) ifTrue:
[subPart visibleGlyphsDo: aBlock].
i _ i - 1].! !
!Glyph methodsFor: 'keyboard'!
handleKeystroke: aCharacter view: aView
"Accept the given character. The default behavior is to do nothing."!
keystrokeVars
"Answer a collection of DBVariables to which to attach edit constraints for handling keyboard input."
^#()!
wantsKeystrokes
"Answer true if I want to get keyboard input. The default behavior is to answer false."
^false! !
!Glyph methodsFor: 'mouse'!
handleMouseDown: mousePoint view: aView
"The mouse button has been pressed. mousePoint is in local coordinates. The default behavior is to do nothing."!
handleMouseMove: mousePoint view: aView
"The message is sent repeatedly while the mouse button is pressed. mousePoint is in local coordinates. The default behavior is to do nothing."!
handleMouseUp: mousePoint view: aView
"The mouse button has gone up. mousePoint is in local coordinates. The default behavior is to do nothing."!
mouseComment
"When mouse input is initiated, the following sequence of events occurs:
1. handleMouseDown:view: is sent to the glyph
2. handleMouseMove: is sent to the glyph repeatedly while the mouse is down
3. handleMouseUp: is sent to the glyph
All of these messages have two arguments: 1) the current mouse position in local coordinates and 2) the view in which this Glyph appears."!
wantsMouse
"Answer true if I want to be informed of mouse activity. The default behavior is to answer false."
^false! !
!Glyph methodsFor: 'utilities'!
compile: aString
"Answer the evaluation of the given code string (which is usually a block). The code is evaluated in the context of this glyph, so it may access the glyph's instance variables."
^Compiler
evaluate: aString
for: self
logged: false!
fill: aRectangle mask: maskForm on: aDisplayMedium at: aDisplayPoint clip: clipBox
(BitBlt
destForm: aDisplayMedium
sourceForm: nil
halftoneForm: maskForm
combinationRule: (Form over)
destOrigin: (aRectangle origin + aDisplayPoint)
sourceOrigin: (0@0)
extent: (aRectangle extent)
clipRect: clipBox)
copyBits.!
hLineFrom: p1 length: length on: aDisplayMedium at: aDisplayPoint clip: clipBox
(BitBlt
destForm: aDisplayMedium
sourceForm: nil
halftoneForm: (Form black)
combinationRule: (Form over)
destOrigin: ((p1 + aDisplayPoint) rounded)
sourceOrigin: (0@0)
extent: (length rounded@1)
clipRect: clipBox) copyBits.!
lineFrom: p1 to: p2 on: aDisplayMedium at: aDisplayPoint clip: clipBox
"Draw a one-bit thick line between the given points."
aDisplayMedium
drawLine: ((Form extent: 1@1) black)
from: ((aDisplayPoint + p1) rounded)
to: ((aDisplayPoint + p2) rounded)
clippingBox: clipBox
rule: (Form over)
mask: (Form black).!
vLineFrom: p1 length: length on: aDisplayMedium at: aDisplayPoint clip: clipBox
"Points are such a common case that it pays to optimize. Thus, we compute the Manhattan distance (i.e. delta x + delta y) between this given point and our location and answer 'true' if the given point is close enough."
^((x value rounded - aPoint x) abs + (y value rounded - aPoint y) abs) < 8!
^self form computeBoundingBox translateBy: self formOffset!
formOffset
"Center my form on my center."
^center - (self form extent // 2)!
initializeWith: aForm
super initialize.
center _ InvisiblePointGlyph new moveTo: 30@30.
form _ aForm.! !
IconGlyph comment:
'I am an abstract class for a special kind of Glyph that displays an icon with a centered text label below it. My subclasses must respond to these messages:
name
name:
icon
icon:
I cache a Form for my name in the instance variable ''nameForm'' for more efficient display. My subclasses must update this cache whenever their name changes by sending me the message updateNameIcon.'!
!IconGlyph methodsFor: 'initialize-release'!
initialize
super initialize.
self name: 'An Icon Glyph'.! !
!IconGlyph methodsFor: 'accessing'!
name
^name!
name: aString
"For efficiency, I cache a Form containing the bitmap for the text of my name."
'I can be used to attach a menu to any real glyph. When the SceneController is in ''run'' mode, the menu will be invoked when the mouse is pressed inside my host''s bounding box. The menu consists of a collection of operation names (stored in ''selectors'') and an associated set of scripts (''scripts''). A script is just a sequence of expressions, like a Smalltalk method except that it cannot have local variables. Scripts are compiled into blocks that are invoked when their selector is selected from the menu. The blocks are kept in the variable ''compiledScripts'''!
"Answer true if either I or my host is in the given list."
^(objectList includes: host) or:
[objectList includes: self]!
inputGlyphsDo: aBlock
"I am an input glyph."
aBlock value: self.!
selectableGlyphsDo: aBlock
"I have none."!
varsDo: aBlock
"I have none."!
visibleGlyphsDo: aBlock
"I have none."! !
!AttachableMenuGlyph methodsFor: 'mouse'!
handleMouseDown: mousePoint view: view
"Invoke or (if the shift key is pressed) edit my menu."
(Sensor leftShiftDown)
ifTrue: [self editMenu: view]
ifFalse: [self invokeMenu: view].!
wantsMouse
^true! !
!AttachableMenuGlyph methodsFor: 'script'!
compile: aString
"Answer the evaluation of the given code string (which is usually a block). The code is evaluated in the context of my host, so it may access the host's instance variables."
^Compiler
evaluate: aString
for: host
logged: false!
editScript: oldScript
"Edit the given script string and answer the new script."
^FillInTheBlank
request:
'Edit the script for this glyph. You many use the pseudovariables
''model'' and ''view,'' as well as instance variables of this glyph.'
initialAnswer: oldScript! !
!AttachableMenuGlyph methodsFor: 'menu'!
addMenuEntry: newSelector script: newScript
"Append the given selector and its script to my menu."
| newCompiledScript |
newCompiledScript _
self compile: ('[: model : view | ', newScript, ']').
selectors addLast: newSelector.
scripts addLast: newScript.
compiledScripts addLast: newCompiledScript.!
addMenuEntryButNot: existingSelectors view: view
"Prompt the user for the selector name and the new script. Disallow selectors from the given set. The script may reference the variables 'model' and 'view' as well as the host glyph's instance variables."
| newSelector newScript |
newSelector _ FillInTheBlank
request: 'Type the selector for the new menu item:'.
"Edit my menu The view is provided to allow feedback by flashing the view. The script for a menu item may reference the variables 'model' and 'view' as well as the host glyph's instance variables."
| sel newEntry index newScript newCompiledScript |
value value: (1 + (offset // (boxSize + boxSpacing))).
(value value ~= oldValue) ifTrue:
[self displayIn: view.
(compiledScript notNil) ifTrue:
[compiledScript value: view model value: view value: value value]]]]].!
handleMouseUp: mousePoint view: view
"Clean up the edit constraint and plan."
(editConstraint notNil) ifTrue:
[editConstraint destroyConstraint.
editConstraint _ nil.
plan release.
plan _ nil].!
wantsMouse
^true! !
AbstractButtonGlyph comment:
'I define the general behavior of buttons. When the SceneController is in ''run'' mode, the button''s script will be invoked when the mouse is pressed and released inside my bounding box. The script which is just a sequence of expressions. A script is like a Smalltalk method except that it cannot have local variables. Scripts are compiled into blocks that are invoked when the button is pressed. Holding the shift key while pushing a button allows the script to be edited. Moving the cursor outside the button before releasing the mouse button aborts the operation.'!
"If the shift key is pressed when the button is invoked, then edit the script immediately. Otherwise, give feedback and invoke the button script only if the mouse goes up inside the button."
(Sensor leftShiftDown)
ifTrue:
[self editScript.
lastMouseInButton _ false]
ifFalse:
[self reverseIn: view.
lastMouseInButton _ true].!
handleMouseMove: mousePoint view: view
"Show feedback. If the mouse is in the button, show it reversed."
| mouseInButton |
mouseInButton _ self containsPoint: mousePoint.
(mouseInButton ~= lastMouseInButton) ifTrue:
[self reverseIn: view.
lastMouseInButton _ mouseInButton].!
handleMouseUp: mousePoint view: view
"If the mouse is still in the button, then invoke or edit (if the shift key is pressed) the script. If the script is nil, it is not invoked."
"Edit my script. The script may reference the variables 'model' and 'view' as well as this glyph's instance variables."
| newScript |
newScript _ FillInTheBlank
request:
'Edit the script for this glyph. You many use the pseudovariables
''model'' and ''view,'' as well as instance variables of this glyph.'
initialAnswer: script.
(newScript ~= script) ifTrue:
[self script: newScript].!
script: scriptString
"Compile and store the given script. The script may reference the variables 'model' and 'view,' as well as this glyph's instance variables."
script _ scriptString.
(scriptString isEmpty)
ifTrue: [compiledScript _ nil]
ifFalse:
[compiledScript _ self compile:
('[: model : view | ', scriptString, ']')].! !
AttachableButtonGlyph comment:
'I can be used to attach a button to any real glyph. When the SceneController is in ''run'' mode, the button will be invoked when the mouse is pressed inside my host''s bounding box. The button has a script which is just a sequence of expressions. A script is like a Smalltalk method except that it cannot have local variables. Scripts are compiled into blocks that are invoked when the button is pressed.'!
"Answer true if either I or my host is in the given list."
^(objectList includes: host) or:
[objectList includes: self]!
inputGlyphsDo: aBlock
"I am an input glyph."
aBlock value: self.!
selectableGlyphsDo: aBlock
"I have none."!
varsDo: aBlock
"I have none."!
visibleGlyphsDo: aBlock
"I have none."! !
!AttachableButtonGlyph methodsFor: 'script'!
compile: aString
"Answer the evaluation of the given code string (which is usually a block). The code is evaluated in the context of my host, so it may access the host's instance variables."
^Compiler
evaluate: aString
for: host
logged: false! !
!TextGlyph methodsFor: 'initialize-release'!
initialize
super initialize.
box _ RectangleGlyph new.
text _ FreeVariable value: 'a TextGlyph'.
font _ FreeVariable value: (TextStyle default fontAt: 1).
(WidthC == nil) ifTrue:
[WidthC _ Constraint
names: #(width text font)
methods: #('width _ QuickPrint width: text inFont: font')].
'Here''s a place multiple inheritance would be handy. A TextButtonGlyph is like both a TextGlyph and an AbstractButtonGlyph. We''ve chosen to make it a subclass of AbstractButtonGlyph and re-implemented the behavior of TextGlyph.'!
"Allows one to put text into the paste buffer from other applications. For example, a form editor can stuff a textual representation of the form into the paste buffer allowing the user to insert it into a method."
CurrentSelection _ aString asText.
self addPreviousSelection: CurrentSelection! !
!StringHolderController class methodsFor: 'class initialization'!
initialize
"Initialize the yellow button pop-up menu and corresponding messages."
This class allows Smalltalk programs to control synthesizers and other musical devices attached via the RS232 port and a midi interface box. Because the Midi port(s) are a shared resource, there are no instances of this class. Instead, Midi control messages are directed to the class itself. You can use the "class refs" facility to find all the users of Midi operations in the system.
1. Be sure to have a Midi interface attached the port you are using. The interface should have a clock speed of 1 Mhz (most do, including the one from Apple). It is possible to hang the system if you open a port that does not have a Midi interface attached (and turned on) because the port depends on a clock signal supplied by the Midi interface -- no clock, no action!!!!
2. The Midi driver is interrupt driven and the interrupt code is part of the Smalltalk interpreter. Thus, if you quit from Smalltalk with one of the Midi ports open and an interrupt occurs (due to a character arriving, say) then your Mac will crash because the drivers aren''t there anymore. Included in this filein is a modification of Smalltalk''s quit method that closes all Midi ports. (Closing a non-open port is harmless.) It is recommended that you include a similar mechanism in any applications you develop yourself. You will have to re-open the Midi port(s) you were using after restarting the image.
3. There is a limit of 1000 bytes per call to the Midi put primitive; you can pass it a bigger buffer but the extra bytes will not be sent.
4. The Midi "put" primitive puts its bytes in an internal buffer until all previous bytes have been sent. If there is not enough room in the buffer, the put primitive waits until there is room. If there IS room in in the buffer, the bytes of the current call are buffered and the call returns to Smalltalk immediately even though not all the bytes have actually been sent.
5. If the transmit buffer is completely full, it takes nearly three seconds to empty itself. (Midi data is sent at 3125 bytes/second, so you have to send a lot of data fast to actually fill up the 8192 byte transmit buffer.) If you close the Midi port before the buffer is empty, some bytes will never be sent. My practice is to keep the Midi port open continuously during a Smalltalk session but if your application opens and closes the port dynamically, you may wish to insert a three second delay before each close operation to absolutely guarantee that all the bytes have been sent.
'!
!Midi class methodsFor: 'initialize-debug'!
debugOff
"Midi debugOff"
Debug _ false.!
debugOn
"When the debugging switch is turned on, all midi output will be printed to the Transcript rather than actually sent. Debugging also enables range checks on the parameters of the outgoing Midi messages."
"Midi debugOn"
Debug _ true.!
initialize
"Midi initialize"
Debug _ false.
InBuf _ BufferStream on: (ByteArray new: 100).
Port _ nil.
self primClose: 0.
self primClose: 1.
Smalltalk removeDependent: self.! !
!Midi class methodsFor: 'port control'!
closePort
"Close the midi port."
"Midi closePort"
Smalltalk removeDependent: self.
(Port isNil) ifFalse: [self primClose: Port].
Port _ nil.!
openPort: portNumber
"Open the given midi port. In case the port is currently open, close it first."
"Midi openPort"
self closePort.
Port _ portNumber.
Smalltalk addDependent: self.
self primOpen: portNumber.!
update: parameter
"Close the port if the user quits Smalltalk to avoid hanging the system."
self send: 176 with: control with: value on: channel.!
noteOff: key chan: channel
"Turns off the given note."
"Detail: Send a 'noteOn' command with zero velocity since not all synthesizers recognize the 'noteOff' command."
self send: 144 with: key with: 0 on: channel.!
noteOn: key vel: velocity chan: channel
"Turns on the given note."
self send: 144 with: key with: velocity on: channel.!
pitchBend: bend chan: channel
"Updates the pitch bend on this channel to the given new value."
self
send: 224
with: (bend bitAnd: 127)
with: (bend bitShift: -7)
on: channel.!
program: program chan: channel
"Changes the synthesizer's 'program number' (or 'instrument' or 'preset') for this channel to the given new value."
self send: 192 with: (program - 1) on: channel.!
synthInit
"Resets the synthesizer. This may need to be changed since devices differ; the idea is to put the synthesizer into a known state for all parameters which might be changed through Midi."
1 to: 16 do:
[: channel |
self control: 123 value: 0 chan: channel. "All notes off on this channel."
self pitchBend: 8192 chan: channel.
self program: 1 chan: channel.
"You may wish to reset various other control values here."].! !
!Midi class methodsFor: 'midi monitor'!
monitor
"This is a simple midi monitor program which deciphers incoming
midi commands and prints them to the transcript until a mouse
button is pressed."
"Midi monitor"
self monitorAllBut: #().!
monitorAllBut: cmdList
"Print midi messages to the transcript until any mouse button is pressed.
"Answer the category name for this glyph. By default, all glyphs are placed in the 'unclassified' category. Subclasses should override this method to put themselves in a more suggestively named category. If the category string is empty, the glyph is not presented at all. This is used to hide abstract superclass glyphs."
^'Unclassified'! !
!Glyph class methodsFor: 'constraint release'!
releaseConstraints
"Used to destroy constraint prototypes stored in class variables. Glyph classes that store constraint prototypes store in class variables should override this message to destroy these constraints. The method objects in these constraints may contain BlockContext's that hold onto pointers to garbage in Smalltalk version 2.3. To get rid of this garbage, do:
FormTable at: 360 put: (FormTable at: 0). "360 is same as 0 degrees"! !
!ArrowHeadGlyph class methodsFor: 'instance creation'!
at: aPoint vector: vectorPoint
"Create a new instance with the given orientation (determined by vectorPoint) and location."
^(super new)
vector: vectorPoint;
moveTo: aPoint! !
!ArrowHeadGlyph class methodsFor: 'classification'!
glyphCategory
^'General'! !
!CircleGlyph class methodsFor: 'classification'!
glyphCategory
^'Geometric'! !
!CapacitorGlyph class methodsFor: 'classification'!
glyphCategory
^'Electronic'! !
!ResistorGlyph class methodsFor: 'classification'!
glyphCategory
^'Electronic'! !
!ParaLinesGlyph class methodsFor: 'classification'!
glyphCategory
^'Geometric'! !
!ParaLinesGlyph class methodsFor: 'constraint release'!
releaseConstraints
DirectionC _ nil.! !
!AdagioParser class methodsFor: 'class initialization'!
initialize
"This table drives the scanner. The first letter of each attribute is looked up here to decide what to do with the rest of the attribute. In the case of spaces and punctuation, no further scanning is required."
scanner drawString: styleName asString, '-', i printString, ' Hello, world!!'.
scanner downBy: font height]].! !
PitchRider class comment:
'PitchRider - IVL PitchRider 400 Control
This class allows Smalltalk programs to control an IVL PitchRider 400 pitch-to-midi interface (ROM version 2.1).'!
!PitchRider class methodsFor: 'high level'!
changeParameter: parameter to: newValue
"Attempt to change the given parameter to the given value and verify that it has been changed. This will fail with an error if the parameter is illegal (in which case the PitchRider ignores it) or if there is a communications failure between the computer and the PitchRider. Answers the new parameters string if the operations succeeds."
!AbstractConstraint class methodsFor: 'utilities'!
getVarAt: aPath in: anObject
"Fetch the DBVariable object at the given path in the given object. If aPath is nil, then simply return the given object."
"NOTE: A path consists of a sequence of unary message selectors separted by period characters. For example, #line1.p2.x refers the DBVariable object found by first sending the message 'line1' to the source object, then sending the message 'p1' to the result of that, and finally sending the 'x' message to the result of that."
| next buffer |
(aPath isNil) ifTrue: [^anObject].
buffer _ WriteStream on: (String new: 16).
next _ anObject.
aPath do:
[: char |
(char == $.)
ifTrue:
[next _ next perform: (buffer contents asSymbol).
buffer reset]
ifFalse:
[buffer nextPut: char]].
(buffer position > 0) ifTrue:
[next _ next perform: (buffer contents asSymbol)].
^next! !
!TwoInOneWayConstraint class methodsFor: 'instance creation'!
!Constraint class methodsFor: 'instance creation'!
names: variableNames methods: methodStrings
"Create a new constraint from the given method strings. The expressions in methodStrings are compiled to produce the actual method bodies for the constraint. For example, the following builds a plus constraint:
Constraint
names: #(sum a b)
methods: #('sum _ a + b' 'a _ sum - b' 'b _ sum - a')
The constraint thus created may be bound to actual variables with a specific strength (see Constraint>bind:strength:)."
| methodList |
methodList _ methodStrings collect:
[: s | Method names: variableNames methodString: s].
"Merge newVar into the merge cluster containing clusterVar."
"Details: To avoid strange topologies possibly leading to cycles, we locate a free end of the merge cluster and merge newVar with that variable. This ensures that merging creates acyclic structures. There is a known problem when a member of a merge is deleted: this may break the merge chain causing things to become unmerged. It could be fixed in the delete operation but for now we choose to live with the problem. The user can always re-merge after a deletion..."
"Answer a variable from the given merge cluster that the given new variable will merged with. This variable will be be at one end of the merge constraint chain (i.e. will have no determining constraint or no using constraint). If newVar is already part of the merge cluster, then answer nil."
| connectionVar mark todo v |
(clusterVar class == FreeVariable) ifTrue: [^clusterVar].
connectionVar _ nil.
mark _ Planner newMark.
todo _ OrderedCollection with: clusterVar.
[todo isEmpty] whileFalse:
[v _ todo removeFirst.
(v mark = mark) ifFalse:
[(v == newVar)
ifTrue: [^nil]
ifFalse:
[(v determinedBy == nil) ifTrue:
[connectionVar _ v].
v constraints do:
[: c |
((c isSatisfied) & (c isMergeConstraint)) ifTrue:
[c inputsDo: [: in | todo addLast: in].
todo addLast: c output]]].
v mark: mark]].
^connectionVar! !
!XMouseConstraint class methodsFor: 'instance creation'!
!CustomMenu class methodsFor: 'instance creation'!
new
^(super new) initialize! !
!CustomMenu class methodsFor: 'example'!
example
"CustomMenu example"
| menu |
menu _ CustomMenu new.
menu add: 'apples' action: #apples.
menu add: 'oranges' action: #oranges.
menu add: 'peaches' action: #peaches.
menu add: 'pears' action: #pears.
^menu invoke: #peaches! !
!Planner class methodsFor: 'class initialization'!
initialize
"Planner initialize"
currentMark _ 1.! !
!Planner class methodsFor: 'add/remove'!
incrementalAdd: c
"Attempt to satisfy the given constraint and, if successful, incrementally update the dataflow graph."
"Details: If satifying the constraint is successful, it may override a weaker constraint on its output. The algorithm attempts to resatisfy that constraint using some other method. This process is repeated until either a) it reaches a variable that was not previously determined by any constraint or b) it reaches a constraint that is too weak to be satisfied using any of its methods. The variables of constraints that have been processed are marked with a unique mark value so that we know where we've been. This allows the algorithm to avoid getting into an infinite loop even if the constraint graph has an inadvertent cycle."
| mark overridden |
mark _ self newMark.
overridden _ c satisfy: mark.
[overridden == nil] whileFalse:
[overridden _ overridden satisfy: mark].!
incrementalRemove: c
"Entry point for retracting a constraint. Remove the given constraint and incrementally update the dataflow graph."
"Details: Retracting the given constraint may allow some currently unsatisfiable downstream constraint be satisfied. We thus collect a list of unsatisfied downstream constraints and attempt to satisfy each one in turn. This list is sorted by constraint strength, strongest first, as a heuristic for avoiding unnecessarily adding and then overriding weak constraints."
"Assume: c is satisfied."
| out unsatisfied |
out _ c output.
c removeFromGraph.
unsatisfied _ self removePropagate: out.
unsatisfied do: [: u | self incrementalAdd: u].! !
!Planner class methodsFor: 'planning/value propagation'!
extractPlanFromInputConstraints: inputConstraints
"Extract a plan for resatisfaction starting from the outputs of the given seed constraints, usually a set of input constraints."
"Details: Collects the satisfied elements of seedConstraints and passes the buck."
| seedConstraints |
seedConstraints _ OrderedCollection new: 1000.
inputConstraints do:
[: c | (c isSatisfied) ifTrue: [seedConstraints add: c]].
^self makePlan: seedConstraints!
extractPlanFromVariables: variables
"Extract a plan from the dataflow graph having the given variables. It is assumed that the given set of variables is complete, or at least that it contains all the input and all the history variables of interest."
"Details: Simply collects satisfied constraints from the given variables and passes the buck."
| seedConstraints |
seedConstraints _ OrderedCollection new: 1000.
variables do:
[: v |
(v constraints) do:
[: c | (c isSatisfied) ifTrue: [seedConstraints add: c]]].
^self makePlan: seedConstraints!
makePlan: seedConstraints
"Extract a plan for resatisfaction starting from the given seed constraints, usually a set of input constraints. This method assumes that stay optimization is desired; the plan will contain only constraints whose output variables are not stay. Constraints that do no computation, such as stay and edit constraints, are not included in the plan."
"Details: The outputs of a constraint are marked when it is added to the plan under construction. A constraint may be appended to the plan when all its input variables are known. A variable is known if either a) the variable is marked (indicating that has been computed by a constraint appearing earlier in the plan), b) the variable is 'stay' (i.e. it is a constant at plan execution time), or c) the variable is not determined by any constraint. The last provision is for past states of history variables, which are not stay but which are also not computed by any constraint."
"Assume: seedConstraints are all satisfied."
| todo mark plan hotC out inC |
todo _ seedConstraints.
mark _ self newMark.
plan _ Plan new.
(todo isEmpty) ifFalse: [hotC _ todo removeFirst].
[hotC == nil] whileFalse:
[((hotC output mark ~= mark) and: "not in plan already and..."
[hotC inputsKnown: mark]) "eligible for inclusion"
ifTrue:
[
hotC output stay ifFalse: [
plan append: hotC.
].
out _ hotC output.
out mark: mark.
hotC _ self nextConstraintIn: todo downstreamOf: out]
ifFalse:
[(hotC output mark ~= mark) ifTrue:
["this code backs up in the constraint graph; this is useful when not all the source nodes are easily determined"
hotC inputsDo:
[: inVar |
inC _ inVar determinedBy.
((inVar stay) or:
[(inC == nil) or:
[inVar mark == mark]]) ifFalse:
[todo addFirst: inC]]].
hotC _ (todo isEmpty)
ifTrue: [nil]
ifFalse: [todo removeFirst]]].
^plan finalize!
propagateFrom: aVariable
"The given variable has changed. Propagate new values downstream."
| todo c |
todo _ OrderedCollection new: 1000.
c _ self nextConstraintIn: todo downstreamOf: aVariable.
[c == nil] whileFalse:
[c execute.
c _ self nextConstraintIn: todo downstreamOf: c output].! !
!Planner class methodsFor: 'testing'!
buildTree: n protoConstraint: protoC
"Answer the root of a tree of constraints like the given prototype n deep. Recursive."
| tree leftSubtree rightSubtree |
(n <= 0)
ifTrue:
[tree _ ConstrainedVariable new.
tree defaultStay]
ifFalse:
[tree _ ConstrainedVariable new.
leftSubtree _ self buildTree: n - 1 protoConstraint: protoC.
rightSubtree _ self buildTree: n - 1 protoConstraint: protoC.
(protoC copy) var: tree var: leftSubtree var: rightSubtree strength: #required].
^tree!
chainTest: n
"Do chain-of-equality-constraints performance tests, printing the results in the Transcript."
"Planner chainTest: 200"
| equalsC vars constraints v1 v2 eqC editConstraint plan |
"This constraint is slower than the special-purpose EqualityConstraint."
equalsC _ Constraint
names: #(a b)
methods: #('a _ b' 'b _ a').
self report: 'Built chain of ', n printString, ' equality constraints in' times: 1 run:
[vars _ (0 to: n) collect: [: i | FreeVariable new].
constraints _ OrderedCollection new: n.
"thread a chain of equality constraints through the variables"
self report: 'Projection test of ', n printString, ' points. Setup:' times: 1 run:
[scale _ ConstrainedVariable value: 10.
offset _ ConstrainedVariable value: 1000.
1 to: n do:
[: i |
src _ ConstrainedVariable value: i.
dst _ ConstrainedVariable value: i.
constraints add: (src defaultStay).
constraints add:
(ScaleConstraint
var: src var: scale var: offset var: dst
strength: #required)]].
self statsFor: scale newValue: 5.
constraints do: [: c | c release].
constraints _ OrderedCollection new: (2 * n).
Transcript cr.
self report: 'ChainTest of ', n printString, ' constraints. Setup:' times: 1 run:
[vars _ (0 to: n) collect: [: i | FreeVariable new].
constraints _ OrderedCollection new: n.
1 to: n do:
[: i |
v1 _ (vars at: i).
v2 _ (vars at: i + 1).
constraints add: (v1 requireEquals: v2)].
vars last strongDefaultStay].
self statsFor: (vars first) newValue: 5.
constraints do: [: c | c release].
vars do: [: v | v release].
Transcript cr.!
projectionTest: n
"This test constructs a two sets of variables related to each other by a simple linear transformation (scale and offset). The time is measured to change a variable on either side of the mapping and to change the scale and offset factors. Results are printed in the Transcript."
plan _ Planner extractPlanFromInputConstraints: (Array with: editConstraint)].
self report: ' ExecutionTime:' times: 100 run:
[aVariable value: newValue. plan execute].
editConstraint destroyConstraint.!
treeTest: n
"Build an adder tree of depth n and measure the time required to change the root."
"Planner treeTest: 5"
| plusC tree |
plusC _ Constraint
names: #(sum a b)
methods: #('a _ sum - b' 'b _ sum - a' 'sum _ a + b').
self report: 'Built adder tree of depth ', n printString, ' in' times: 1 run:
[tree _ self buildTree: n protoConstraint: plusC].
self reportChange: 'Changing root of tree' var: tree newValue: 10.! !
!Planner class methodsFor: 'private'!
addPropagate: aConstraint mark: mark
"Recompute the walkabout strengths and stay flags of all variables downstream of the given constraint and recompute the actual values of all variables whose stay flag is true. If a cycle is detected, remove the given constraint and answer false. Otherwise, answer true."
"Details: Cycles are detected when a marked variable is encountered downstream of the given constraint. The sender is assumed to have marked the inputs of the given constraint with the given mark. Thus, encountering a marked node downstream of the output constraint means that there is a path from the constraint's output to one of its inputs."
"Note: This method has been hand-optimized for better performance."
| nextC oldOutValue cOut constraints determiningC i d todo |
nextC _ aConstraint.
oldOutValue _ aConstraint output value.
[nextC == nil] whileFalse:
[cOut _ nextC recalculate.
(cOut mark = mark) ifTrue:
[aConstraint output value: oldOutValue.
self incrementalRemove: aConstraint.
^false].
"The remaining code in this block is equivalent to:
'nextC _ self nextConstraintIn: todo downstreamOf: v'"
nextC _ nil.
constraints _ cOut constraints.
determiningC _ cOut determinedBy.
i _ constraints size.
[i > 0] whileTrue:
[d _ constraints at: i.
((d == determiningC) not and: [d isSatisfied]) ifTrue:
"Details: We just keep incrementing. If necessary, the counter will turn into a LargePositiveInteger. In that case, it will be a bit slower to compute the next mark but the algorithms will all behave correctly. We reserve the value '0' to mean 'unmarked'. Thus, this generator starts at '1' and will never produce '0' as a mark value."
"Update the walkabout strengths and stay flags of all variables downstream of the given constraint. Answer a collection of unsatisfied constraints sorted in order of decreasing strength."
nextC _ self nextConstraintIn: todo downstreamOf: v.
(nextC == nil) ifTrue: [^unsatisfied].
v _ nextC recalculate].! !
!Planner class methodsFor: 'cycle detection'!
couldMakeCycle: aConstraint
"Answer true if adding the given constraint could produce a cycle. SLOW!!!!"
| mark |
aConstraint possibleMethodsDo:
[: inputs : output |
mark _ self newMark.
self markDownstreamFrom: output mark: mark.
inputs do: [: in | (in mark = mark) ifTrue: [^true]]].
^false!
markDownstreamFrom: aVariable mark: mark
"Mark all variables downstream of the given variable with the given mark."
| todo v |
todo _ OrderedCollection new: 1000.
v _ aVariable.
[true] whileTrue:
[v mark: mark.
v constraints do:
[: c |
c possibleMethodsDo:
[: inputs : output |
((output mark == mark) or: [output == v]) ifFalse:
[todo add: output]]].
(todo isEmpty) ifTrue: [^self].
v _ todo removeFirst].! !
!MidiRecorder class methodsFor: 'class initialization'!
initialize
"MidiRecorder initialize."
InitialSize _ 500.
"Build the default midi action table. This table is a 255 element array of actions to be performed when a byte whose value is the entries index is received. Note that DefaultMidiTable at: 0 is not defined; however, we never actually use a data byte (< 128) to index into the table."
!NoteElement class methodsFor: 'instance creation'!
new
"Creates a new note with default values."
^super new initialize!
new: pitch at: time dur: duration
"Creates a new instance of me with the given pitch starting at the given starting time and lasting for the given duration. Other attributes are given reasonable defaults."
^(self basicNew)
vel: 75 pitch: pitch voice: 1;
time: time;
dur: duration!
new: pitch at: time dur: duration vel: velocity voice: voice
"Creates a new instance of me with the given pitch, velocity, and voice starting at the given starting time and lasting for the given duration."
'A BufferStream is a re-usable ReadWriteStream. The message resetAll will reset both the readLimit and the current position (making it empty). BufferStream is used by the Adagio parser and for Midi input.'!
!BufferStream methodsFor: 'special'!
buffer
"Answer my buffer (collection) to allow direct access for high performace I/O. Experts only!!!!"
^collection!
resetAll
"Resets both the read and write positions so that the BufferStream becomes empty and may be re-used."
readLimit _ position _ 0.!
setReadLimit: newLimit
"Sets the readLimit to newLimit. No sanity check is performed, so be sure you know what you are doing!!"
readLimit _ newLimit!
throughEnd
"Answer a sub-collection containing all the unread characters in the buffer."
^collection copyFrom: position + 1 to: readLimit! !
Method comment:
'I represent a method whose enforement procedure is stored in a Smalltalk block. Users may create custom methods by supplying an assignment expression string and a set of formal constrained variable names. See my instance creation protocol for further details.
Instance variables:
block block to execute to enforce the constraint <BlockContext>
'!
!Method methodsFor: 'initialize-release'!
names: variableNames methodString: methodString
"Initialize a method by compiling the given string considering the given collection of variable names to represent the parameters of the method (i.e. its inputs and outputs). A given variable may not be both an input and an output. Note: Any free variables in the methodString will be considered global (if they appear in 'Smalltalk') or temporary variables. The user is given a warning, however, since such cases are unusual and a free variable may indicate a typographical error."
"Answer a string to be used as the prefix when creating a block for a method with the given input names. All constraint variables are declared as temporaries, in addition to the temporary variables from the method string. Input variable temporaries are initialized from the argument vector."
| stream |
stream _ WriteStream on: (String new).
"build the expression prefix, making all the variables look like temps"
stream nextPutAll: '| '.
argNames do: [: v | stream nextPutAll: v; space].
tempNames do: [: v | stream nextPutAll: v; space].
"Extract the input, output and temporary variable names from the Smalltalk expression represented by the given string. A temporary variable is one that is neither an input, an output, or a global. Answer an array containing the three lists (ins, outs, temps)."
| s parseTree ins outs temps |
s _ (String new: 200) writeStream.
s nextPutAll: 'DoIt'; cr; cr.
s tab; nextPutAll: '| '.
allNames do: [: vName | s nextPutAll: vName; space].
s nextPutAll: '|'; cr; tab; nextPutAll: methodString.
"Answer the index of the method output in the constraint variables. Raise an error if the input and output arg lists are not disjoint or if there is not exactly one output. Warn the user if the method code has free variables (these will be made into temporaries)."
'I collect a list of ordered sub-sequences which can later be merged into a single, sorted sequence. Objects may be added to the current sub-sequence using ''add:'' or ''addCheck:''. (''addCheck:'' will check the assumption that the sub-sequence is really sorted in ascending order.) A new sub-sequence is started with the message ''startNewSublist''. I was created for use by the Adagio parser by I can also be used to merge scores.
'!
!MergeSorter methodsFor: 'initialize-release'!
reset
"Reset to pristine, empty state."
lists _ OrderedCollection new: 40.
currList _ nil.
lastAdded _ nil.
self startNewSublist.! !
!MergeSorter methodsFor: 'accessing'!
add: anItem
"Adds anItem to the current list."
currList addLast: anItem.
lastAdded _ anItem.!
addCheck: anItem
"Adds anItem to my current list. Checks the assumption that anItem is >= to the last item added."
((lastAdded notNil) and: [anItem < lastAdded])
ifTrue: [self error: 'Attempt to add an item out of sequence'].
self add: anItem.!
size
"Answer the total count of all items added to me since the last time I was reset."
"Initialize me with the given prototype constraint, paths, and strength symbol."
protoConstraint _ aBinaryConstraint.
fromPath _ fromPathSymbol.
toPath _ toPathSymbol.
extraVars _ nil.
strengthSymbol _ aSymbol.!
constraintFrom: object1 to: object2
"Answer a an instance of my prototype constraint on the given pair of objects using fromPath and toPath to access the appropriate fields of the two objects."
(leftOfC copy) var: p1 xVar var: p1 xVar last var: p2 xVar var: p2 xVar last strength: #required.
(leftOfC copy) var: p2 xVar var: p2 xVar last var: p3 xVar var: p3 xVar last strength: #required.
(leftOfC copy) var: p3 xVar var: p3 xVar last var: p4 xVar var: p4 xVar last strength: #required.
SceneView openOn: scene.!
mapTests: which
"Computes the performance of maintaining pair-wise relationships between two sets using either direct (which = #direct) or virtual (which = #virtual) constraints."
^setVars collect: [: setVar | setVar value contents]! !
!String methodsFor: 'converting'!
asScore
"Answer the Adagio score resulting from parsing me."
^AdagioParser parse: self readStream! !
Score comment:
'I am a subclass of OrderedCollection used to store collections of notes. I know how to perform the score I contain. (Aside: it may be desirable to implement a separate player class to allow a given score to be played as a cannon with itself. If so, the performance technique used here may be copied and extended.)
My instance variables are:
scoreTime a cache for the total score duration
maxDur a cache of the duration of my longest note
noteCount the total size of this score (used during performance)
nextIndex index of the next note to play during a performance
activeNotes list of active notes (notes that have been struck but not released)
'!
!Score methodsFor: 'functions'!
edit
"Open a piano-roll editor on myself."
PianoRollView openOn: self.!
maxDur
"Answer the duration of my longest note in centiseconds. This quantity is cached in my maxDur instance variable and only recomputed if maxDur is nil."
maxDur isNil
ifTrue: [maxDur _ self computeMaxDur].
^maxDur!
maxVoice
"Answer the number of the highest numbered voice in myself."
^self
inject: 1
into:
[: maxVoice : scoreEl |
(scoreEl isNote)
ifTrue: [maxVoice max: scoreEl voice]
ifFalse: [maxVoice]]!
mergedWith: aScore
"Answer a new score that consists of all my elements merged with all the elements of aScore."
| sorter |
sorter _ MergeSorter new.
self do: [: note | sorter add: note copy].
sorter startNewSublist.
aScore do: [: note | sorter add: note copy].
^sorter asScore!
scoreTime
"Answer my total playing time in centiseconds. This quantity is cached in my scoreTime instance variable and only recomputed if scoreTime is nil."
scoreTime isNil
ifTrue: [scoreTime _ self computeScoreTime].
^scoreTime! !
!Score methodsFor: 'positioning'!
findIndexForTime: aTime
"Do a binary search to find the first score element with the given time."
| index low high |
low _ firstIndex.
high _ lastIndex.
[index _ high + low // 2.
low <= high]
whileTrue:
[((self basicAt: index) time < aTime)
ifTrue: [low _ index + 1]
ifFalse: [high _ index - 1]].
^(low + 1 - firstIndex) min: self size!
indexAfter: aTime
"Answer the index of my first element that is after the given time or the index of my last element is greater than the time of my last element."
| index size |
index _ self findIndexForTime: aTime.
size _ self size.
[(index < size) and: [(self at: index) time <= aTime]]
whileTrue: [index _ index + 1].
^index!
indexBefore: aTime
"Answer the index of my last element that is at or before the given time or my first index if aTime is less than the time of my first element."
"Plays the entire score at the given rate. theRate is 1 for normal speed, 2 for twice speed, 0.75 for three-quarter speed, etc."
| rate mSecsAtStart ticks currTime |
"Skip to the first note at or after the given time, processing all control changes and program changes along the way to establish the proper synthesizer state."
"Reset the next note pointer (nextIndex) and the active note list to prepare the score to be played from the beginning."
noteCount _ self size.
nextIndex _ 1.
(activeNotes isNil)
ifTrue:
[activeNotes _ MusicEventQueue new.
activeNotes sortBlock:
[: e1 : e2 | e1 offTime < e2 offTime]]
ifFalse: [activeNotes removeAll].!
prepareToPlayFrom: time
"Processes the score up through the given time without playing any notes. All control and program changes are performed to set the state of the synthesizer as if the score had been actually performed."
aStream nextPutAll: 't0 r u0 v', voice printString; cr.
self storeVoice: voice on: aStream.
(voice ~~ maxVoice) ifTrue:
[aStream cr; cr]].!
storeAdagioOnFile: aFileName
"Write an Adagio representation of myself to a file with the given name."
"NOTE: Only the notes of the score are recorded. This could be extended to store control changes or other kinds of score elements but so far that has not been needed."
| aStream |
aStream _ FileStream newFileNamed: aFileName.
aStream nextPutAll: '* ', aFileName; cr.
self storeAdagioOn: aStream.
aStream close.!
storeVoice: voice on: aStream
"Write an Adagio representation of the given voice to the given stream. To allow nice formatting, the method NoteElement>storeAdagioOn:previous:next: is passed the notes immediately preceding and following the note to be output (which may be nil)."
| oldNextIndex previousTone thisTone nextTone |
"save nextIndex (used for enumeration) and start voice enumeration"
oldNextIndex _ nextIndex.
nextIndex _ 1.
"get first three tones"
previousTone _ self nextNoteInVoice: voice.
thisTone _ self nextNoteInVoice: voice.
nextTone _ self nextNoteInVoice: voice.
"store first tone, if there is one (the voice could be empty)"
"Compute and answer the duration of my longest note in centiseconds."
^self
inject: 0
into:
[: max : scoreEl |
((scoreEl isNote) and: [scoreEl dur > max])
ifTrue: [scoreEl dur]
ifFalse: [max]]!
computeScoreTime
"Compute and answer my total playing time in centiseconds."
| endTime noteEnd |
endTime _ 0.
self do:
[: n |
(n isNote)
ifTrue:
[noteEnd _ n offTime.
(noteEnd > endTime) ifTrue: [endTime _ noteEnd]]
ifFalse:
[(n time > endTime) ifTrue: [endTime _ n time]]].
^endTime!
deepCopy
^self copy!
nextNoteInVoice: voice
"Answer the next note of myself in the given voice at or after nextIndex. Non-note score elements are skipped. Set nextIndex to point to the next scoreElement. Answer nil if the end of the score is reached. Details: This method uses the instance variable nextIndex to maintain state between invocations. The client should set nextIndex to 1 to start the enumeration."
| scoreEl |
[nextIndex <= self size] whileTrue:
[scoreEl _ self at: nextIndex.
nextIndex _ nextIndex + 1.
((scoreEl voice == voice) & (scoreEl isNote))
ifTrue: [^scoreEl]].
^nil!
playThrough: time
"Play the score up through the given time and answer the time of the next action to be performed (either the next event or the time of the next note to be turned off)."
| event nextTime |
self turnOffNotesAt: time.
[(nextIndex <= noteCount) and:
[(event _ self at: nextIndex) time <= time]] whileTrue:
[event perform.
(event isNote) ifTrue:
[activeNotes add: event].
nextIndex _ nextIndex + 1].
"compute and answer the time of the next activity"
(nextIndex <= noteCount)
ifTrue: "not done yet"
[nextTime _ (self at: nextIndex) time.
(activeNotes isEmpty) ifFalse:
[nextTime _ nextTime min: (activeNotes first offTime)]]
ifFalse: "done playing notes; may have some noteoffs yet"
[(activeNotes isEmpty)
ifTrue: [nextTime _ time + 1]
ifFalse: [nextTime _ (activeNotes first offTime)]].
^nextTime max: (time + 1) "always advance by at least one tick"!
playThrough: time volume: volume
"Play the score up through the given time at the given volume and answer the time of the next action to be performed (either the next event or the time of the next note to be turned off)."
| event nextTime |
self turnOffNotesAt: time.
[(nextIndex <= noteCount) and:
[(event _ self at: nextIndex) time <= time]] whileTrue:
[(event isNote)
ifTrue:
[Midi
noteOn: (event pitch)
vel: (volume min: 127)
chan: (event voice).
activeNotes add: event]
ifFalse: [event perform].
nextIndex _ nextIndex + 1].
"compute and answer the time of the next activity"
(nextIndex <= noteCount)
ifTrue: "not done yet"
[nextTime _ (self at: nextIndex) time.
(activeNotes isEmpty) ifFalse:
[nextTime _ nextTime min: (activeNotes first offTime)]]
ifFalse: "done playing notes; may have some noteoffs yet"
[(activeNotes isEmpty)
ifTrue: [nextTime _ time + 1]
ifFalse: [nextTime _ (activeNotes first offTime)]].
^nextTime max: (time + 1) "always advance by at least one tick"!
setIndices
"Override OrderedCollection's method for this initialization method since we anticipate adding things at the end. (We most frequently use addLast: rather than addFirst: to add to Score objects.)"
firstIndex _ 1.
lastIndex _ 0.!
turnOffNotesAt: time
"Turns off all notes in the active list with times at or before the given time."
[(activeNotes size > 0) and:
[(activeNotes first offTime) <= time]] whileTrue:
[activeNotes removeFirst turnOff].! !
!Score methodsFor: 'conducting'!
conduct: voiceList
"Conduct the given voices of this score. That is, watch for incoming Midi note-on and note-off events and play one chord or note of the score for each note-on event, at the velocity given by the note-on event. The pitches of the note-on and -off events are irrelevant. This works best with velocity-sensitive keyboards and in situations where the keyboard used for conducting is does not cause notes to be sounded. If voiceList is not nil, only the given voices will be played."
"Remove and turn off the the notes in activeNotes."
activeNotes do: [: note | note turnOff].
activeNotes setIndices.! !
MusicEventQueue comment:
'I am a ''priority queue'' data structure stored as a heap. The basic operations on a priority queue are add: and removeFirst. At any given time, removeFirst answers the highest priority element in the queue. Elements may be ordered according to the default ''<'' relation (which gives higher priority to smaller elements) or the client may supply a sort block that takes two elements and evaluates to true if the first has higher priority than the second. I am a subclass of collection and thus support do:, collect:, and so on but it should be noted that elements are not stored in completely sorted order internally, so the iteration will not process elements in strict priority order. It should also be noted that I do NOT support random access to my elements; only the highest priority element may be examined (with ''first'') or removed (with ''removeFirst'').'!
!MusicEventQueue methodsFor: 'public'!
add: newElement
"Insert the given element in the receiver at the proper location."
(last == contents size) ifTrue:
["queue is full, so double the size of 'contents' to make room"
contents _ (Array new: (last * 2))
replaceFrom: 1 to: last with: contents startingAt: 1].
last _ last + 1.
contents at: last put: newElement.
self pushUpFrom: last.!
do: aBlock
"Evaluate aBlock with each of the receiver's elements as the argument."
| i |
i _ 1.
[i <= last] whileTrue:
[aBlock value: (contents at: i).
i _ i + 1].!
first
"Answer the least element of the receiver without removing it."
(last == 0) ifTrue: [^self errorEmptyCollection].
"The root is the smallest element."
^contents at: 1!
isEmpty
"Answer true if the queue is empty."
^last == 0!
remove: oldObject ifAbsent: anExceptionBlock
self shouldNotImplement.!
removeAll
"Make the receiver empty."
last _ 0.!
removeFirst
"Remove and answer the least element of the receiver."
| smallest oldLast |
(last == 0) ifTrue: [^self errorEmptyCollection].
"The root is the smallest element."
smallest _ contents at: 1.
"Remove the last element and replace the root it. Then push it down."
oldLast _ contents at: last.
contents at: last put: nil.
last _ last - 1.
contents at: 1 put: oldLast.
self pushDownFrom: 1.
^smallest!
size
"Answer how many elements the receiver contains."
^last!
sortBlock: aBlock
"Register a custom sort block. The block should take two arguments, elements of the receiver, and evaluate to true if the first is less than the second (to sort smallest first) or vice versa (to sort largest first)."
sortBlock _ aBlock.! !
!MusicEventQueue methodsFor: 'private'!
element: e1 precedes: e2
"Answer true if element e1 precedes element e2 under the ordering relation. Use 'sortBlock' if the user supplied one, otherwise use '<' operator to directly compare the elements."
^(sortBlock == nil)
ifTrue: [e1 < e2]
ifFalse: [sortBlock value: e1 value: e2]!
initialize: initialSize
"Allocate initial space for the given number of elements."
contents _ Array new: initialSize.
last _ 0.
sortBlock _ nil.!
pushDownFrom: index
"Push the element at index i down through the tree until it is smaller than its children or until it is a leaf with no children."
| leaves parent left right child parentElement childElement |
leaves _ last bitShift: -1.
parent _ index.
[parent <= leaves] whileTrue: "while parent is not a leaf:"
doAdds: addBlock removes: removeBlock since: id synchBlock: synchBlock
"Process all operations on this collection since the operation with the given id. addBlock(removeBlock) is called for each add(remove) operation in sequence and is passed the added(removed) element. If the history doesn't contain an entry with uid, or contains a #synch operation, then invoke synchBlock to resynchronize the client. Answer the uid of the most recent history entry."
ifTrue: [synchBlock value] "too much has happened; re-synch"
ifFalse:
[["process at least one entry"
(self processAt: i add: addBlock remove: removeBlock) ifFalse:
[synchBlock value.
^mostRecentID].
i _ (i == histSize) ifTrue: [1] ifFalse: [i + 1].
i ~~ oldest] whileTrue: ["process until we wrap around to oldest"]].
^mostRecentID!
processAt: index add: addBlock remove: removeBlock
"Process the trace entry at the given index, invoking the appropriate client block. Answer true if the operation is #add or #remove, false otherwise (which means that we must re-synchronize)."
"Record the given operation on the given element along with a unique ID."
"Details: The collection history is a circular buffer ordered from least to most recent. The index of the oldest entry is 'oldest'. This is the entry that will next be recorded over. The entry immediately preceding the oldest entry (modulo the history size) is the most recent. The length of the history is fixed at initialization time."
"I don't understand what's on the file. Scan for a blank chunk and hope for the best."
[self nextChunkStream atEnd] whileFalse: []! !
ScoreElement comment:
'ScoreElement is an abstract superclass for things that can be placed in scores, such as NoteElements, NoteOffs, ProgramChanges, ControlChanges, and so forth. The salient feature of all ScoreElements is that they all have a time and can be sorted accordingly.'!
!ScoreElement methodsFor: 'accessing'!
time
"Answer the performance time of this ScoreElement in centiseconds."
^time!
time: newTime
"Set the performance time of this ScoreElement to the given time."
time _ newTime.! !
!ScoreElement methodsFor: 'testing'!
isNote
^false! !
!ScoreElement methodsFor: 'comparing'!
< aScoreElement
"Answer true if I am at an earlier time than aScoreElement."
^self time < aScoreElement time!
<= aScoreElement
"Answer true if I am at an earlier or the same time as aScoreElement."
^self time <= aScoreElement time!
> aScoreElement
"Answer true if I am at a later time than aScoreElement."
^self time > aScoreElement time!
>= aScoreElement
"Answer true if I am at a later or the same time as aScoreElement."
^self time >= aScoreElement time! !
!ScoreElement methodsFor: 'performing'!
perform
"Perform myself. This is a placeholder that subclasses override to actually do something."
self subclassResponsibility! !
NoteElement comment:
'I am a subclass of ScoreElement that represents a soundable note. In order to allow one to fit larger scores in memory, my space is optimized at a very slight cost in additional access time. I pack three of my attributes into one instance SmallInteger instance variable as follows:
my voice (0-31) -- lowest 5 bits of velocityPitchVoice
my pitch (0-127) -- next 7 bits of velocityPitchVoice
my velocity (0-127) -- next 7 bits of velocityPitchVoice
'!
!NoteElement methodsFor: 'initialize-release'!
initialize
"Initialize myself with reasonable default parameters."
(velocityPitchVoice bitAnd: -32 "all but lowest 5 bits").! !
!NoteElement methodsFor: 'testing'!
isNote
^true! !
!NoteElement methodsFor: 'performing'!
perform
"Perform myself."
Midi
noteOn: (self pitch)
vel: (self velocity)
chan: (self voice).!
turnOff
"Turn myself off."
Midi
noteOn: (self pitch)
vel: 0
chan: (self voice).! !
!NoteElement methodsFor: 'print/store'!
adagioPitchString
"Translate my pitch to a symbolic pitch. Having no concept of key signature, we choose a note spelling arbitrarily. Note: Pitches use the CMU Midi Toolkit standard of middle C = 48 versus the Midi standard of middle C = 60. For example, C4 = P48 is middle C, B3 = P47 is the B half a step below that, and the top and bottom notes of a piano are A0 = P9 and C9 = P108 respectively. The full Midi range is P-12 to P115."
| octave name |
octave _ (self pitch // 12) - 1.
name _ #(c cs d ef e f fs g gs a bf b) at: ((self pitch \\ 12) + 1).
"Write an Adagio language description of myself to the given stream. To allow nicer printing, the notes immediately preceding and following me in my voice are supplied if they exist (otherwise nil is supplied instead)."
'A Scene is a two-dimensional diagram or picture composed of displayable objects called glyphs. Each glyph must respond to the basic protocol for Glyphs (see class Glyph). A scene also maintains a list of selected glyphs and can enumerate various kinds of the glyphs: visible, selectable, and input-accepting.
' ***** Why use Constraint Hierarchies? (Sums) *****
Constraint hierarchies are useful for many parts of a software system including: (i) as a declarative specification for defaults, (ii) as a mechanism to describe the behavior of a graphical user interface, and (iii) as a mechanism for declaratively controlling the dataflow. Typically, to control the flow of data in a "flat" constraint system one must use some operational features. For example, many constraint system use a well-defined search mechanism and thus the user can write his or her rules to take advantage of that mechanism to control the dataflow, i.e., he or she can use non-declarative features. Of course, if the system is improved and the search algorithm changes, the program no longer works correctly. One of the benefits of using a constraint hierarchy is that the hierarchy can control the dataflow declaratively.
The no-hierarchy demo has a flat constraint system and just a little experimentation will illustrate that its behavior is difficult to predict. Specifically, the data does not flow from left-to-right as one might expect. The hierarchy demo uses constraints of different strengths to cause the "correct" dataflow. Furthermore, any constraint hierarchy solver will produce exactly the same solutions for this second demo, regardless of its implementation (assuming, of course, that the solver is implemented correctly.)
'!
!Plus1Demo methodsFor: 'initialize-release'!
create
"Plus1Demo releaseConstraints"
| texts xs ys ps |
Transcript cr; show: 'Building the ' , self class name , '..'.
Transcript cr; show: '..adding the components'.
values _ Array new: 7.
1 to: values size do: [:i | values at: i put: (FreeVariable value: 10)].
texts _ Array new: values size.
1 to: values size do: [:i | texts at: i put: BoxTextGlyph new].
xs _ #(50 50 150 150 250 250 350 ).
ys _ #(50 150 100 200 150 250 200 ).
ps _ OrderedCollection new.
xs with: ys do: [:x :y | ps add: x @ y].
texts with: ps do:
[:text :p |
text moveTo: p].
xs _ #(100 200 300 ).
ys _ #(100 150 200 ).
1
to: 5
by: 2
do:
[:i |
p _ ThreeProngTextGlyph new initialize.
p
left: (texts at: i) center
right: (texts at: i + 2) center
down: (texts at: i + 1) center
string: '+'.
self addGlyph: p].
texts do: [:each | self addGlyph: each].
Transcript cr; show: '..adding the consistency constraints'.
Just as a database demo is not complete with the Employee relation and a graphics demo is not complete without rendering a teapot, a constraint demo is not complete with the Celsius-Fahrenheit example.
Constraints are multi-directional, automatically-maintained assertions about the state of a system. For example, the relation between Celsius and Fahrenheit temperatures is a constraint. Constraints are often stated as equations, but other mechanism are both possible and are used in these demos.
This demo uses many different types of constraints: arithmetic constraints to maintain the relation between the different interpretations of temperature; layout constraints to keep the title under each thermometer, the equations between the thermometers, and the number beside the mercury; and consistency constraints to keep the mercury height proportional to the temperature which in turn is equal to the text printed beside it. Last, but not least, special graphical constraints are used to control the display when the temperature gets too cold or too hot (Try 10 Kelvin or 200 Celsius!!). Yes, the entire demo is composed of many smaller objects working together, synchronized and kept consistent with constraints.
Interesting actions to try are: (1) moving the mercury up and down, (2) selecting and then entering a temperature directly (use <delete> and the number keys), (3) switching to "edit" mode and rearranging the thermometers (press the mouse button on the title bar to get a menu which includes "edit". Use the same menu to return to "operate").
'!
!CFKDemo methodsFor: 'initialize-release'!
create
| c f k c1 tc tf tk tcf tck mpc |
Transcript cr; show: 'Building the ', self class name, '..'.
Transcript cr; show: '..adding the Fahrenheit thermometer'.
f _ ThermometerGlyph new initialize.
f moveTo: 50 @ 160.
f overVal: 752.0 underVal: -184.0.
self addGlyph: f.
Transcript cr; show: '..adding the Celsius thermometer'.
c _ ThermometerGlyph new initialize.
c moveTo: 250 @ 160.
c overVal: 400.0 underVal: -120.0.
self addGlyph: c.
Transcript cr; show: '..adding the Kelvin thermometer'.
k _ ThermometerGlyph new initialize.
k moveTo: 450 @ 160.
k minVal: 0.
k maxVal: 400.
k overVal: 450.0 underVal: -1.0.
self addGlyph: k.
Transcript cr; show: '..adding the consistency constraints'.
topView borderWidth: 1; addSubView: (SceneView new initialize model: self).
topView controller open! !
SplittingDemo comment:
' ***** Constraint on Objects (Multi-User Application) *****
These demos illustrate two features of constraint systems: (one) constraints can be useful in the development of today''s multi-user, multi-media, multi-buzzword applications, and (two) constraints on complex objects can be implemented in a number of ways. These demos illustrate two mechanisms: splitting (decomposing a constraint on a whole object into separate constraints on each of its parts) and raising (moving constraints on an object''s parts "up" to become constraints on the whole object). Numerous other mechanisms also exist.
In these examples, we assume a two-user, two-mouse interactive graphical editor. Here, however, the second user is simulated by the computer. Note that even while the second user is busy editting her objects, the first user (you) can still edit yours. Again, this is because all interactions are implemented with constraints and the system can solve many constraints just as easily as it can solve a few.
Each of these demos has a horizontal line and a vertical line. The first user (you) are supposed to drag the right end of the horizontal line and the second user to drag the bottom end of the vertical line. This works well in the splitting demo. In the raising demo, however, the system has raised the constraints too far and has removed precious degrees of freedom from the objects. Thus the constraints (you, the second user, horizontal, vertical) cannot all be solved simultaneously.
'!
!SplittingDemo methodsFor: 'initialize-release'!
create
| hl vl m c |
Transcript cr; show: 'Building the ' , self class name , '..'.
Transcript cr; show: '..adding the components'.
m _ FakeMouseGlyph new initialize.
hl _ LineGlyph new.
hl moveTo: 100 @ 100.
vl _ LineGlyph new.
vl moveTo: 100 @ 150.
self addGlyph: m; addGlyph: hl; addGlyph: vl.
Transcript cr; show: '..adding the consistency constraints'.
' ***** What is a Constraint Hierarchy? (Anchors and Mice) *****
A constraint hierarchy is an ordered sequence of sets of constraints such that the constraints in the stronger sets dominate those in the weaker sets. For example, if "X = 5" is strong and "X = 3" is weak, the solution would be "X = 5". The strongest set in a constraint hierarchy is the required level: these constraints must be satisified. All other levels are preferred and should be satisfied (respecting their various strengths) may be violated if necessary.
These three examples demonstrate different constraint hierarchies. In the no-anchor example, the only constraints are the "horizontal line" constraint and (when the mouse drags a point) the "mouse drags point" constraint. (Note: all interactions are implemented using constraints, thus the connection between the mouse and the point it is dragging is actually a constraint.) In the anchor example, there is a strong "anchor" constraint which holds the left point in place. This anchor constraint is stronger than the mouse constraint, and thus the mouse cannot move the left end and it can only move the right end back and forth. In the anchor-strong-mouse example, the mouse has been made stronger than the anchor and thus the mouse can drag the anchor around again.
To summarize, the three examples have the following constraint hierarchies:
* no-anchor * * anchor * * anchor-strong-mouse *
required horizontal line required horizontal line required horizontal line
"Install the simulation constraints that cause nodes to move according to the forces applied to them. Record a plan to execute continuously. The simulation can be stopped by registering a nil plan."
Constraints are especially useful for two aspects of graphics: static layout and dynamic behavior. Constraints can be used to declaratively specify the layout of various graphical objects to ensure that positioning and other relations are maintained. Perhaps more interesting, though, is the use of constraints to define dynamic behavior, e.g., animations. Constraints are a natural mechanism for describing physical laws (even imaginary "Wiley E. Coyote" ones).
These two demos illustrate the use of simple animation constraints. In the fake-gravity demo, the slides control the orbit radius of the two planets and simple computation is used to find the next position of each planet. Interestingly enough, the animation can continue while the user is interacting with the system---after all, the user''s interaction is implemented by constraints and the animation is implemented by constraints, thus the system can automatically solve the two sets together. Thus the user can move the slider while the planets orbit. However, the user can also grab any planet and drag it around and the other planets will continue their orbits, although now centered on the user''s planet. This "re-centering" is because the user''s interaction constraint is stronger than the rest.
In the real-gravity demo, the slider control gravity and the four vectors illustrate the acceleration and velocity of the two planets. All of the constraints are multi-directional, thus if the planets are dragged around, the vectors will indicate the velocity and acceleration of the mouse!! And, if the velocity vector is dragged around, the acceleration and planet motion will match, and so on. Unfortunately, it is very difficult to get the planets to orbit (or to do anything at all) which is why the fake-gravity demo is also supplied.
"Extract the variations for each marimba from the given score. marimbaList is a collection containing a variations list for each marimba used in the piece. A variations list is simply a list of Adagio voices of the given score corresponding to the variations (Adagio voice = one variation). The first part in the list is the 'basic' variation for that marimba. Voices are renumbered to correspond to marimbas.
' ***** Complex Graphical User Interfaces (MacDraw II) *****
This demo was taken from the MacDraw II Dashed Lines dialog box, a user interface widget for defining the number and length of the black and white dashes that, together, comprise a dashed line. In the original MacDraw II, this dialog box was implemented completely in Pascal: the programmer designed the box, extracted the constraints, hand-solved them, coded them in Pascal, and debugged and debugged and debugged. In this version, the behavior is almost completely defined by constraints. Even the existence or non-existence of the dashes is defined by constraints.
This dialog box uses three basic types of constraints: data consistency constraints, graphical constraints, and behavioral constraints. Data consistency constraints include: no dash shall be shorted than 5 pixels. No dash shall be longer than 125 pixels. There must be at least two dashes. There can be no more than six dashes. Etc. Graphical constraints include keeping the "draggers" aligned with the right end of their respective dash expect for the last one which can be dragged to the far right edge to delete a dash. Behavioral constraints are basically internal but include such things as the existence of dashes and draggers, and "snapping" action which occurs when the last dragger is released between the right end of its dash and the right edge of the box.
Interesting actions to try include: (1) trying to shrink a dash too far, (2) trying to grow a dash too large, (3) dragging the last dragger to the far right, (4) dragging the dragger on the far right (if there you left it there) off the far right "parking" place, (5) trying to compact a dash on the right by shoving it against the edge with a dash from the middle, and (6) releasing the last dragger half-way between the end of its dash and the right edge of the box.
'!
!MacDrawDemo methodsFor: 'initialize-release'!
create1
| c d |
Transcript cr; show: 'Building the ' , self class name , '..'.
Transcript cr; show: '..adding the dashes'.
dashes _ d _ Array new: 6.
1 to: d size do: [:i | d at: i put: (MacDrawDashGlyph new initialize: i)].
(d at: 1) left0 value: MacDrawDemo leftEdge.
2 to: d size + 1 do:
[:i |
(d at: i - 1) right0 value: (d at: i - 1) left0 value + (d at: i - 1) length0 value.
(d at: i - 1) right1 value: (d at: i - 1) left1 value + (d at: i - 1) length1 value.
(d at: i - 1) right2 value: (d at: i - 1) left2 value + (d at: i - 1) length2 value.
(d at: i - 1) right3 value: (d at: i - 1) left3 value + (d at: i - 1) length3 value.
"Answer a set containing all variables used in this parse tree."
| vars |
vars _ IdentitySet new.
self apply:
[: node |
(node isMemberOf: VariableNode)
ifTrue: [vars add: node name asSymbol].
true].
self removePredefinedVarsFrom: vars.
^vars!
assignedTo
"Answer a collection of the variables assigned to in this parse tree."
| vars |
vars _ IdentitySet new.
self apply:
[: node |
(node isMemberOf: AssignmentNode)
ifTrue: [vars add: node variable name asSymbol].
true].
self removePredefinedVarsFrom: vars.
^vars!
referenced
"Answer a collection of the variables that are referenced but not assigned to in this parse tree."
| vars |
vars _ IdentitySet new.
self apply:
[: node |
(node isMemberOf: VariableNode)
ifTrue: [vars add: node name asSymbol. true]
ifFalse:
[(node isMemberOf: AssignmentNode)
ifTrue: [vars addAll: node value referenced. false]
ifFalse: [true]]].
self removePredefinedVarsFrom: vars.
^vars!
removePredefinedVarsFrom: varList
"Remove the pre-defined variable names from the given collection."
#(self super true false nil thisContext) do:
[: predefinedVar |
varList remove: predefinedVar ifAbsent: []].! !
!ReturnNode methodsFor: 'DeltaBlue'!
apply: aBlock
(aBlock value: self) ifTrue:
[expr apply: aBlock].! !
!CascadeNode methodsFor: 'DeltaBlue'!
apply: aBlock
(aBlock value: self) ifTrue:
[receiver apply: aBlock.
messages do: [: m | m apply: aBlock]].! !
!BlockNode methodsFor: 'DeltaBlue'!
apply: aBlock
(aBlock value: self) ifTrue:
[statements do: [: s | s apply: aBlock]].! !
!AssignmentNode methodsFor: 'DeltaBlue'!
apply: aBlock
(aBlock value: self) ifTrue:
[variable apply: aBlock.
value apply: aBlock].!
value
^value!
variable
^variable! !
!MethodNode methodsFor: 'DeltaBlue'!
apply: aBlock
(aBlock value: self) ifTrue:
[block apply: aBlock].! !
!MessageNode methodsFor: 'DeltaBlue'!
apply: aBlock
(aBlock value: self) ifTrue:
[(receiver notNil)
ifTrue: [receiver apply: aBlock].
arguments do: [: a | a apply: aBlock]].! !
!LeafNode methodsFor: 'DeltaBlue'!
apply: aBlock
aBlock value: self.! !
!VariableNode methodsFor: 'DeltaBlue'!
name
^name! !
FreeVariable comment:
'I represent an unconstraint variable. I turn into a ConstrainedVariable when a constraint is added to me.
Instance variables:
value my value; changed by constraints, read by client <Object>
'!
!FreeVariable methodsFor: 'initialize-release'!
initialize
value _ 0.! !
!FreeVariable methodsFor: 'access'!
addConstraint: aConstraint
"Turn myself into a constrained variable and then add the constraint."
| newSelf |
newSelf _ ConstrainedVariable value: value.
newSelf addConstraint: aConstraint.
self become: newSelf.!
constraints
^#()!
last
"Turn myself into a HistoryVariable and then return my previous state variable."
| newSelf newLast |
newSelf _ HistoryVariable value: value.
newLast _ newSelf last.
self become: newSelf.
^newLast!
mark
"I'm never marked."
^0!
mark: ignore
"I don't have any constraints, so ignore this message."!
removeConstraint: ignore
"I don't have any constraints, so ignore this message."!
speciallast
"Turn myself into a HistoryVariable and then return my previous state variable."
| newSelf newLast |
newSelf _ HistoryVariable value: value.
newLast _ newSelf speciallast.
self become: newSelf.
^newLast!
stay
"Answer true since I am unconstrained."
^true!
usedBy
^#()!
value
"Answer my value."
^value!
value: anObject
"Set my value."
value _ anObject.! !
!FreeVariable methodsFor: 'changes'!
changeIn: aBlock
"Allow the given block to change my value."
aBlock value.!
changeIn: aBlock strength: strengthSymbol
"Allow the given block to change my value."
aBlock value.!
setAll: variables to: values
"Attempt to assign the given values to the given variables using a strength of #preferred. This is an all-or-nothing operation; if any variable cannot be changed due to a stronger constraint then no variable is changed."
(ConstrainedVariable new) setAll: variables to: values strength: #preferred.!
setAll: variables to: values strength: strengthSymbol
"Attempt to assign the given values to the given variables using the given strength. This is an all-or-nothing operation; if any variable cannot be changed due to a stronger constraint then no variable is changed."
(ConstrainedVariable new) setAll: variables to: values strength: strengthSymbol.!
setValue: aValue
"Change my value."
value _ aValue.!
setValue: aValue strength: strengthSymbol
"Change my value."
value _ aValue.! !
!FreeVariable methodsFor: 'history'!
advanceHistory
"I have no history, so this is a noop."!
advanceHistory: newValue
"I am the end of a history chain, so update my state and return."
'I represent a constrained variable. In addition to my value, I maintain the structure of the constraint graph, the current dataflow graph, and various parameters of interest to the DeltaBlue incremental constraint solver.
Instance variables:
value my value; changed by constraints, read by client <Object>
constraints normal constraints that reference me <Array of Constraint>
determinedBy the constraint that currently determines
my value (or nil if there isn''t one) <Constraint>
walkStrength my walkabout strength <Strength>
stay true if I am a planning-time constant <Boolean>
mark used by the planner to mark constraints <Number>'!
"Add the given constraint to the set of all constraints that refer to me."
constraints add: aConstraint.!
constraints
"Answer the set of constraints that refer to me."
^constraints!
constraints: collectionOfConstraints
"Set the the set of constraints that refer to me. Most clients should used addConstraints: and removeConstraints:."
constraints _ collectionOfConstraints.!
determinedBy
"Answer the constraint that determines my value in the current dataflow."
^determinedBy!
determinedBy: aConstraint
"Set the given constraint to be the one that determines my value in the current data flow."
determinedBy _ aConstraint.!
last
"Turn myself into a HistoryVariable and then return the variable for my previous state."
| newSelf newLast |
newSelf _ (HistoryVariable new)
value: value;
constraints: constraints;
determinedBy: determinedBy;
walkStrength: walkStrength;
stay: stay;
mark: mark.
newLast _ newSelf last.
self become: newSelf.
^newLast!
mark
"Answer my mark value."
^mark!
mark: markValue
"Set my mark value."
mark _ markValue.!
removeConstraint: c
"Remove all traces of c from this variable."
constraints remove: c ifAbsent: [].
(determinedBy == c) ifTrue: [determinedBy _ nil].!
stay
"Answer my stay flag."
^stay!
stay: aBoolean
"Set my stay flag."
stay _ aBoolean!
unsatisfiedConstraintsInto: aCollection
"Add to the given collection all unsatisfied constraints that refer to me."
| i c |
i _ constraints size.
[i > 0] whileTrue:
[c _ constraints at: i.
(c isSatisfied) ifFalse: [aCollection add: c].
i _ i - 1].!
value
"Answer my value."
^value!
value: anObject
"Set my value."
value _ anObject.!
walkStrength
"Answer my walkabout strength in the current dataflow."
^walkStrength!
walkStrength: aStrength
"Set my walkabout strength in the current dataflow."
walkStrength _ aStrength.! !
!ConstrainedVariable methodsFor: 'changes'!
changeIn: aBlock
"Attempt to add a prefered edit constraint to myself and execute the given block only if this constraint can be satisfied (i.e. no stronger constraint prevents me from changing)."
self changeIn: aBlock strength: #preferred.!
changeIn: aBlock strength: strengthSymbol
"Attempt to add an edit constraint of the given strength to myself and execute the given block only if this constraint can be satisfied (i.e. no stronger constraint prevents me from changing)."
"Attempt to assign the given values to the given variables using a strength of #preferred. This is an all-or-nothing operation; if any variable cannot be changed due to a stronger constraint then no variable is changed."
self setAll: variables to: values strength: #preferred.!
setAll: variables to: values strength: strengthSymbol
"Attempt to assign the given values to the given variables using the given strength. This is an all-or-nothing operation; if any variable cannot be changed due to a stronger constraint then no variable is changed."
| allSatisfied editConstraints editConstraint |
(variables size = values size) ifFalse:
[^self error: 'variable and value lists must be same size'].
"add edit constraints"
allSatisfied _ true. "true iff all edit constraints are satisfied"
editConstraints _ variables collect:
[: v |
editConstraint _ EditConstraint var: v strength: strengthSymbol.
["do the assignments only if all edit constraints are satisfied"
variables with: values do:
[: thisVar : thisValue |
thisVar value: thisValue.
Planner propagateFrom: thisVar]].
"remove edit constraints"
editConstraints do: [: c | c destroyConstraint].!
setValue: aValue
"Attempt to assign the given value to me using a strength of #preferred."
self setValue: aValue strength: #preferred.!
setValue: aValue strength: strengthSymbol
"Attempt to assign the given value to me using the given strength."
"Details: Allow stay propagation to propagate the new value as a side effect of adding a Stay constraint. We know the stay constraint can be added if it is stronger than my walkabout strength."
last pointer to the variable representing my previous value <some kind of FreeVariable or nil>
'!
!HistoryVariable methodsFor: 'history'!
advanceHistory
"Advance my history by sending my value to the next variable in the history chain, if there is one."
(last == nil) ifFalse:
[last advanceHistory: value].!
advanceHistory: newValue
"This message is sent to each past state of a variable's history. The given value is used as the new value for this stage in the history chain. The previous value of this stage is passed to the next older stage via a recursive call to advanceHistory:. The recursion terminates when it reaches a stage with no previous state (i.e. last = nil)."
| myOldValue |
(last == nil)
ifTrue: [value _ newValue]
ifFalse:
[myOldValue _ value.
value _ newValue.
last advanceHistory: myOldValue].!
last
"Answer the DBVariable for my previous state. If there isn't one yet, create one and remember it."
(last == nil) ifTrue:
[last _ HistoryVariable value: value.
last walkStrength: Strength required.
last stay: false].
^last!
speciallast
"Answer the DBVariable for my previous state. If there isn't one yet, create one and remember it."
(last == nil) ifTrue:
[last _ HistoryVariable value: value.
last walkStrength: Strength absoluteWeakest.
last stay: false].
^last! !
PianoRollView comment:
'I represent a view of a PianoRoll.'!
!PianoRollView methodsFor: 'initialize-release'!
initialize
"Initialize my instance variables."
super initialize.
timeOffset _ 0.
timeScale _ 1.
visibleNotes _ OrderedCollection new.
rate _ 100.0.
selected _ IdentitySet new.
leftSelTime _ 0.
rightSelTime _ 0.
voiceActive _ Array new: 32 withAll: true.!
openOn: aScore
"Open a new view of myself on the given score."
| paletteView topView |
paletteView _ PaletteView new.
self model: aScore.
self borderWidth: 1.
self borderColor: Form black.
self initializePalette: paletteView.
topView _ StandardSystemView new
borderWidth: 1;
borderColor: Form black;
label: 'Piano Roll Editor';
addSubView: paletteView
in: (0@0 corner: 1@0.2) borderWidth: 1;
addSubView: self
in: (0@0.2 corner: 1@1) borderWidth: 1;
minimumSize: 320@220.
topView controller open.! !
!PianoRollView methodsFor: 'accessing'!
cacheUpdate
| endTime startIndex endIndex note |
endTime _ self endVisibleSpan.
startIndex _ model indexBefore: (self startVisibleSpan - model maxDur).
endIndex _ (model indexAfter: endTime).
visibleNotes _ visibleNotes species new: (visibleNotes size).
(startIndex = 0) ifTrue: [^self].
startIndex to: endIndex do:
[: index |
note _ model at: index.
"if the note overlaps the visible timespan, record it in visibleNotes"
"Display a note box directly on the display. Used for quick feedback."
| box |
box _ self insetDisplayBox.
self
on: Display at: box origin clip: box
displayNoteBox: noteBox selected: noteSelected.!
displayStavesOn: aForm at: offset clip: clipBox
"Display the pitch lines for a piano roll on the given form. A horizontal gray line is drawn for each black key of the piano. A darker line marks middle C."
BlackKeyPitches do:
[: pitch |
self
on: aForm
at: offset
clip: clipBox
lineAt: (self pitchToY: pitch)
rule: Form over
mask: Form lightGray].
self
on: aForm
at: offset
clip: clipBox
lineAt: (self pitchToY: 60)
rule: Form over
mask: Form gray.!
displayView
"Externally visible method to display a score in piano-roll notation. Update visible note cache first."
self cacheUpdate.
self quickDisplayView.!
on: aForm at: offset clip: clipBox displayNoteBox: noteBox selected: noteSelected
"Display a note box with the given shade of gray."
self
on: aForm
at: offset
clip: clipBox
fill: noteBox
rule: Form over
mask: Form black.
noteSelected ifTrue:
[self
on: aForm
at: offset
clip: clipBox
fill: (noteBox expandBy: -1@-1)
rule: Form erase
mask: Form black].!
on: aForm at: offset clip: clipBox fill: rect rule: rule mask: mask
"Fill a rectangle on the given form with the given shade of gray using the given rule."
(BitBlt
destForm: aForm
sourceForm: nil
halftoneForm: mask
combinationRule: rule
destOrigin: rect origin + offset
sourceOrigin: 0@0
extent: rect extent
clipRect: clipBox)
copyBits!
on: aForm at: offset clip: clipBox lineAt: y rule: rule mask: mask
"Draw a horizontal line of the given shade of gray across the given form using the given rule."
'I support a view containing a set of PaletteButtons. This is useful for building user interfaces such as the piano roll editor.'!
!PaletteView methodsFor: 'initialize-release'!
initialize
super initialize.
self
model: nil;
borderWidth: 1;
insideColor: Form white.
buttons _ OrderedCollection new.!
release
buttons do: [: b | b release].
buttons _ nil.! !
!PaletteView methodsFor: 'access'!
addButton: aButton
"Add the given button to my button list."
aButton view: self.
buttons add: aButton.!
buttons
^buttons!
removeButton: aButton
"Remove the given button from my button list."
buttons remove: aButton ifAbsent: [].! !
!PaletteView methodsFor: 'display'!
displayView
"Display all my buttons."
buttons do: [: b | b display].! !
!PaletteView methodsFor: 'controller access'!
defaultControllerClass
"Answer the class of my default controller."
^PaletteController! !
SpecialSystemView comment:
'I provide a different window from for my contents. The title of the window is centered and the title bar extends the entire width of the window. Large or small title text is supported.'!
"Answer the rectangle containing just the text part of my label. This rectangle is in the coordinate system whose origin is the top-left corner of my label."
"Intercept this message to allow me to re-compute my label frame when the view is re-sized."
super window: newWind viewport: newViewport.
self expandLabelFrame.! !
SceneView comment:
'I am a view used to display a Scene. I may be scrolled by adjusting my offset. My default controller is SceneController.
SceneViews encapsulate the notion of a changing foreground and a fixed background during interactive updates. During an interaction (such as dragging), some of the glyphs will not change location or appearance. These are part of the "background". All glyphs that may change (the "foreground" glyphs) are painted against this unchanging backdrop during the interaction.
Instance Variables:
offset the current offset of this view (used for scrolling)
enclosingRect a rectangle large enough to contain all the objects in the scene, plus a small border (this is a cache that must be recomputed when glyphs are moved, added, or removed from the scene)
backgroundForm a <Form> containing the fixed background
visibleForeground the glyphs that are changing but not selected during an interaction
selectedForeground the selected glyphs that are changing during an interaction'!
!SceneView methodsFor: 'initialize-release'!
initialize
super initialize.
scrollOffset _ 0@0.
enclosingRect _ 0@0 corner: 0@0.!
model: aScene
super model: aScene.
self computeBackground.! !
!SceneView methodsFor: 'label access'!
newLabel: aString
"Change my label to be the given string."
self topView deEmphasize.
self topView newLabel: aString.
self topView emphasize.! !
!SceneView methodsFor: 'scrolling'!
scrollOffset
"Answer my scrolling offset."
^scrollOffset!
scrollOffset: aPoint
"Set my scroll offset after first limiting it to lie within the envelope of permissible values."
"Compute the backgroundForm and the two lists, visibleForeground and selectedForeground. These are used by the 'displayFeedback' and 'displayFeedbackWithBox:width:' operations. Put glyphs that depend on a point being changed by a constraint into the foreground."
"Update my display during a user interaction. The client must have called 'computeBackgroundWhileChanging:' to prepare for this operation."
self displayFeedbackWithBox: nil width: nil.!
displayFeedbackWithBox: aRectangle width: w
"Update my display during a user interaction. The client must have called 'computeBackground' to prepare for this operation. If it is not nil, the given rectangle is drawn with the given border width as additional feedback."
| tempForm viewOrigin clipBox |
tempForm _ backgroundForm deepCopy.
viewOrigin _ self viewOrigin.
clipBox _ tempForm computeBoundingBox.
(model glyphsVar stay)
ifTrue:
[visibleForeground do:
[: g | g displayOn: tempForm at: viewOrigin clip: clipBox].
selectedForeground do:
[: g | g highlightOn: tempForm at: viewOrigin clip: clipBox]]
ifFalse:
[model visibleGlyphsDo:
[: g | g displayOn: tempForm at: viewOrigin clip: clipBox].
model selected do:
[: g | g highlightOn: tempForm at: viewOrigin clip: clipBox]].
[: g | g displayOn: tempForm at: viewOrigin clip: clipBox].
model selected do:
[: g | g highlightOn: tempForm at: viewOrigin clip: clipBox].
tempForm
displayOn: Display
at: self insetDisplayBox origin + scrollOffset
clippingBox: self insetDisplayBox.!
displayView
"This method is called by the system when the top view is framed or moved."
| myExtent |
myExtent _ self insetDisplayBox extent.
model viewWidthVar setValue: (myExtent x) strength: #required.
model viewHeightVar setValue: (myExtent y) strength: #required.
self computeEnclosingRectangle.
self displayScene.!
isAlive
^model notNil! !
!SceneView methodsFor: 'controller access'!
defaultControllerClass
^SceneController! !
!SceneView methodsFor: 'coordinates'!
computeEnclosingRectangle
"Compute a rectangle capable of enclosing all visible glyphs in this view. The rectangle's corners are computed and then expanded to allow room for a border. This method should be called any time glyphs are added, removed or moved."
